home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / necsrc.tz / necsrc / nec2d.f next >
Text File  |  1992-09-29  |  249KB  |  9,175 lines
  1. C     PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14,
  2. C    1TAPE15,TAPE16,TAPE20,TAPE21)
  3. C
  4. C     NUMERICAL ELECTROMAGNETICS CODE (NEC2)  DEVELOPED AT LAWRENCE
  5. C     LIVERMORE LAB., LIVERMORE, CA.  (CONTACT G. BURKE AT 415-422-8414
  6. C     FOR PROBLEMS WITH THE NEC CODE.)
  7. C     FILE CREATED 4/11/80.
  8. C
  9. C                ***********NOTICE**********
  10. C     THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK
  11. C     SPONSORED BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED
  12. C     STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF
  13. C     THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR
  14. C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
  15. C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
  16. C     COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT
  17. C     OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
  18. C     INFRINGE PRIVATELY-OWNED RIGHTS.
  19. C
  20. C     DOUBLE PRECISION 6/4/85
  21. C
  22.       INCLUDE 'NEC2DPAR.INC'
  23.       PARAMETER (IRESRV=4000000)
  24.       IMPLICIT REAL*8(A-H,O-Z)
  25.       CHARACTER AIN*2,ATST*2,INFILE*80,OUTFILE*80,INMSG*48,OUTMSG*40
  26. C***
  27.       REAL*8 HPOL,PNET
  28.       INTEGER*2 GPWNXY(2)
  29.       LOGICAL*4 GetPut,LGTPT
  30.       COMPLEX*16  CM,FJ,VSANT,ETH,EPH,ZRATI,CUR,CURI,ZARRAY,ZRATI2
  31.       COMPLEX*16  EX,EY,EZ,ZPED,VQD,VQDS,T1,Y11A,Y12A,EPSC,U,U2,XX1,XX2
  32.       COMPLEX*16  AR1,AR2,AR3,EPSCF,FRATI
  33.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  34.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  35.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  36.      &IPSYM
  37.       COMMON /CMB/CM(IRESRV)
  38.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  39.      1ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  40.       COMMON/SAVE/IP(2*MAXSEG),KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,
  41.      &FMHZ
  42.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  43.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  44.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  45.      1IPERF,T1,T2
  46.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  47.       COMMON/YPARM/NCOUP,ICOUP,NCTAG(5),NCSEG(5),Y11A(5),Y12A(20)
  48.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
  49.      1IPCON(10),NPCON
  50.       COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
  51.      1IQDS(30),NVQD,NSANT,NQDS
  52.       COMMON/NETCX/ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,
  53.      1MASYM,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),
  54.      1X22R(30),X22I(30),NTYP(30)
  55.       COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,
  56.      1RFLD,GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,
  57.      1NEAR,NFEH,NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
  58.       COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),
  59.      1DYA(3),XSA(3),YSA(3),NXA(3),NYA(3)
  60.       COMMON/GWAV/U,U2,XX1,XX2,R1,R2,ZMH,ZPH
  61. C***
  62.       COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  63. C***
  64.       DIMENSION CAB(1),SAB(1),X2(1),Y2(1),Z2(1)
  65.       DIMENSION LDTYP(30),LDTAG(30),LDTAGF(30),LDTAGT(30),ZLR(30),
  66.      1ZLI(30),ZLC(30)
  67.       DIMENSION ATST(22),PNET(6),HPOL(3),IX(2*MAXSEG)
  68.       DIMENSION FNORM(200)
  69.       DIMENSION T1X(1),T1Y(1),T1Z(1),T2X(1),T2Y(1),T2Z(1)
  70. C***
  71.       DIMENSION XTEMP(MAXSEG),YTEMP(MAXSEG),ZTEMP(MAXSEG),
  72.      &SITEMP(MAXSEG),BITEMP(MAXSEG)
  73.       EQUIVALENCE (CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
  74.       EQUIVALENCE (T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),
  75.      1 (T2Z,ITAG)
  76.       DATA ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP','CM',
  77.      1 'NX','EN','TL','PT','KH','NH','PQ','EK','WG','CP','PL'/
  78.       DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/
  79.       DATA PNET/6H      ,2H  ,6HSTRAIG,2HHT,6HCROSSE,1HD/
  80.       DATA TA/1.745329252D-02/,CVEL/299.8/
  81.       DATA LOADMX,NSMAX,NETMX/30,30,30/,NORMF/200/
  82. 706   CONTINUE
  83. C
  84. C***VAX
  85. C      TYPE 700
  86. 700   WRITE(*,*) ' ENTER NAME OF INPUT FILE >'
  87. 701   FORMAT(A)
  88.       READ(*,701,ERR=702) INFILE
  89.       IF(INFILE.EQ.' ')INFILE='SYS$INPUT'
  90. C      OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ACTION='READ',ERR=702)
  91.       OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',READONLY,ERR=702)
  92. 707   CONTINUE
  93. C      TYPE 703
  94. 703   WRITE(*,*) ' ENTER NAME OF OUTPUT FILE >'
  95.       READ(*,701,ERR=704) OUTFILE
  96.       IF(OUTFILE.EQ.' ')OUTFILE='SYS$OUTPUT'
  97. C      OPEN (UNIT=3,FILE=OUTFILE,STATUS='NEW',ERR=704)
  98.       OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704)
  99.       GO TO 705
  100. 702   CALL ERROR
  101.       GO TO 706
  102. 704   CALL ERROR
  103.       GO TO 707
  104. C***MAC
  105. C     OPEN IN AND OUT FILES WITH DIALOG BOX FOR MACINTOSH
  106. C
  107. C      INMSG='Select nec input file    (NEC-2D)               '
  108. C      OUTMSG='Enter name of output file               '
  109. C      GPWNXY(1)=50
  110. C      GPWNXY(2)=100
  111. C702   LGTPT= GetPut(1,GPWNXY,INMSG,INFILE,IVOL,1,'TEXT')
  112. C      IF(.NOT.LGTPT)STOP
  113. C      OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ACTION='READ',ERR=702)
  114. C704   LGTPT= GetPut(0,GPWNXY,OUTMSG,OUTFILE,IVOL,1,'TEXT')
  115. C      IF(.NOT.LGTPT)STOP
  116. C      OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704)
  117. C      WRITE(*,*)' NEC-2D RUN IN PROGRESS'
  118. C***MAC
  119. 705   CONTINUE
  120.       CALL SECOND(EXTIM)
  121.       FJ=(0.,1.)
  122.       LD=MAXSEG
  123.       NXA(1)=0
  124. 1     KCOM=0
  125. C***
  126.       IFRTIMW=0
  127.       IFRTIMP=0
  128. C***
  129. 2     KCOM=KCOM+1
  130.       IF (KCOM.GT.5) KCOM=5
  131.       READ(2,125)AIN,(COM(I,KCOM),I=1,19)
  132.       CALL UPCASE(AIN,AIN,LAIN)
  133.       IF(KCOM.GT.1)GO TO 3
  134.       WRITE(3,126)
  135.       WRITE(3,127)
  136.       WRITE(3,128)
  137. 3     WRITE(3,129) (COM(I,KCOM),I=1,19)
  138.       IF (AIN.EQ.ATST(11)) GO TO 2
  139.       IF (AIN.EQ.ATST(1)) GO TO 4
  140.       WRITE(3,130)
  141.       STOP
  142. 4     CONTINUE
  143.       DO 5 I=1,LD
  144. 5     ZARRAY(I)=(0.,0.)
  145.       MPCNT=0
  146.       IMAT=0
  147. C
  148. C     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN
  149. C
  150.       CALL DATAGN
  151.       IFLOW=1
  152.       IF(IMAT.EQ.0)GO TO 326
  153. C
  154. C     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION
  155. C
  156.       NEQ=N1+2*M1
  157.       NEQ2=N-N1+2*(M-M1)+NSCON+2*NPCON
  158.       CALL FBNGF(NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11)
  159.       GO TO 6
  160. 326   NEQ=N+2*M
  161.       NEQ2=0
  162.       IB11=1
  163.       IC11=1
  164.       ID11=1
  165.       IX11=1
  166.       ICASX=0
  167. 6     NPEQ=NP+2*MP
  168.       WRITE(3,135)
  169. C
  170. C     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
  171. C
  172. C***
  173.       IPLP1=0
  174.       IPLP2=0
  175.       IPLP3=0
  176.       IPLP4=0
  177. C***
  178.       IGO=1
  179.       FMHZS=CVEL
  180.       NFRQ=1
  181.       RKH=1.
  182.       IEXK=0
  183.       IXTYP=0
  184.       NLOAD=0
  185.       NONET=0
  186.       NEAR=-1
  187.       IPTFLG=-2
  188.       IPTFLQ=-1
  189.       IFAR=-1
  190.       ZRATI=(1.,0.)
  191.       IPED=0
  192.       IRNGF=0
  193.       NCOUP=0
  194.       ICOUP=0
  195.       IF(ICASX.GT.0)GO TO 14
  196.       FMHZ=CVEL
  197.       NLODF=0
  198.       KSYMP=1
  199.       NRADL=0
  200.       IPERF=0
  201. C
  202. C     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
  203. C     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
  204. C
  205. 14    CALL READMN(2,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,
  206.      &TMP5,TMP6)
  207.       MPCNT=MPCNT+1
  208.       WRITE(3,137) MPCNT,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,
  209.      1TMP4,TMP5,TMP6
  210.       IF (AIN.EQ.ATST(2)) GO TO 16
  211.       IF (AIN.EQ.ATST(3)) GO TO 17
  212.       IF (AIN.EQ.ATST(4)) GO TO 21
  213.       IF (AIN.EQ.ATST(5)) GO TO 24
  214.       IF (AIN.EQ.ATST(6)) GO TO 28
  215.       IF (AIN.EQ.ATST(14)) GO TO 28
  216.       IF (AIN.EQ.ATST(15)) GO TO 31
  217.       IF (AIN.EQ.ATST(18)) GO TO 319
  218.       IF (AIN.EQ.ATST(7)) GO TO 37
  219.       IF (AIN.EQ.ATST(8)) GO TO 32
  220.       IF (AIN.EQ.ATST(17)) GO TO 208
  221.       IF (AIN.EQ.ATST(9)) GO TO 34
  222.       IF (AIN.EQ.ATST(10)) GO TO 36
  223.       IF (AIN.EQ.ATST(16)) GO TO 305
  224.       IF (AIN.EQ.ATST(19)) GO TO 320
  225.       IF (AIN.EQ.ATST(12)) GO TO 1
  226.       IF (AIN.EQ.ATST(20)) GO TO 322
  227.       IF (AIN.EQ.ATST(21)) GO TO 304
  228. C***
  229.       IF (AIN.EQ.ATST(22)) GO TO 330
  230. C***
  231.       IF (AIN.NE.ATST(13)) GO TO 15
  232.       CALL SECOND(TMP1)
  233.       TMP1=TMP1-EXTIM
  234.       WRITE(3,201) TMP1
  235.       STOP
  236. 15    WRITE(3,138)
  237.       STOP
  238. C
  239. C     FREQUENCY PARAMETERS
  240. C
  241. 16    IFRQ=ITMP1
  242.       IF(ICASX.EQ.0)GO TO 8
  243.       WRITE(3,303) AIN
  244.       STOP
  245. 8     NFRQ=ITMP2
  246.       IF (NFRQ.EQ.0) NFRQ=1
  247.       FMHZ=TMP1
  248.       DELFRQ=TMP2
  249.       IF(IPED.EQ.1)ZPNORM=0.
  250.       IGO=1
  251.       IFLOW=1
  252.       GO TO 14
  253. C
  254. C     MATRIX INTEGRATION LIMIT
  255. C
  256. 305   RKH=TMP1
  257.       IF(IGO.GT.2)IGO=2
  258.       IFLOW=1
  259.       GO TO 14
  260. C
  261. C     EXTENDED THIN WIRE KERNEL OPTION
  262. C
  263. 320   IEXK=1
  264.       IF(ITMP1.EQ.-1)IEXK=0
  265.       IF(IGO.GT.2)IGO=2
  266.       IFLOW=1
  267.       GO TO 14
  268. C
  269. C     MAXIMUM COUPLING BETWEEN ANTENNAS
  270. C
  271. 304   IF(IFLOW.NE.2)NCOUP=0
  272.       ICOUP=0
  273.       IFLOW=2
  274.       IF(ITMP2.EQ.0)GO TO 14
  275.       NCOUP=NCOUP+1
  276.       IF(NCOUP.GT.5)GO TO 312
  277.       NCTAG(NCOUP)=ITMP1
  278.       NCSEG(NCOUP)=ITMP2
  279.       IF(ITMP4.EQ.0)GO TO 14
  280.       NCOUP=NCOUP+1
  281.       IF(NCOUP.GT.5)GO TO 312
  282.       NCTAG(NCOUP)=ITMP3
  283.       NCSEG(NCOUP)=ITMP4
  284.       GO TO 14
  285. 312   WRITE(3,313)
  286.       STOP
  287. C
  288. C     LOADING PARAMETERS
  289. C
  290. 17    IF (IFLOW.EQ.3) GO TO 18
  291.       NLOAD=0
  292.       IFLOW=3
  293.       IF (IGO.GT.2) IGO=2
  294.       IF (ITMP1.EQ.(-1)) GO TO 14
  295. 18    NLOAD=NLOAD+1
  296.       IF (NLOAD.LE.LOADMX) GO TO 19
  297.       WRITE(3,139)
  298.       STOP
  299. 19    LDTYP(NLOAD)=ITMP1
  300.       LDTAG(NLOAD)=ITMP2
  301.       IF (ITMP4.EQ.0) ITMP4=ITMP3
  302.       LDTAGF(NLOAD)=ITMP3
  303.       LDTAGT(NLOAD)=ITMP4
  304.       IF (ITMP4.GE.ITMP3) GO TO 20
  305.       WRITE(3,140)  NLOAD,ITMP3,ITMP4
  306.       STOP
  307. 20    ZLR(NLOAD)=TMP1
  308.       ZLI(NLOAD)=TMP2
  309.       ZLC(NLOAD)=TMP3
  310.       GO TO 14
  311. C
  312. C     GROUND PARAMETERS UNDER THE ANTENNA
  313. C
  314. 21    IFLOW=4
  315.       IF(ICASX.EQ.0)GO TO 10
  316.       WRITE(3,303) AIN
  317.       STOP
  318. 10    IF (IGO.GT.2) IGO=2
  319.       IF (ITMP1.NE.(-1)) GO TO 22
  320.       KSYMP=1
  321.       NRADL=0
  322.       IPERF=0
  323.       GO TO 14
  324. 22    IPERF=ITMP1
  325.       NRADL=ITMP2
  326.       KSYMP=2
  327.       EPSR=TMP1
  328.       SIG=TMP2
  329.       IF (NRADL.EQ.0) GO TO 23
  330.       IF(IPERF.NE.2)GO TO 314
  331.       WRITE(3,390)
  332.       STOP
  333. 314   SCRWLT=TMP3
  334.       SCRWRT=TMP4
  335.       GO TO 14
  336. 23    EPSR2=TMP3
  337.       SIG2=TMP4
  338.       CLT=TMP5
  339.       CHT=TMP6
  340.       GO TO 14
  341. C
  342. C     EXCITATION PARAMETERS
  343. C
  344. 24    IF (IFLOW.EQ.5) GO TO 25
  345.       NSANT=0
  346.       NVQD=0
  347.       IPED=0
  348.       IFLOW=5
  349.       IF (IGO.GT.3) IGO=3
  350. 25    MASYM=ITMP4/10
  351.       IF (ITMP1.GT.0.AND.ITMP1.NE.5) GO TO 27
  352.       IXTYP=ITMP1
  353.       NTSOL=0
  354.       IF(IXTYP.EQ.0)GO TO 205
  355.       NVQD=NVQD+1
  356.       IF(NVQD.GT.NSMAX)GO TO 206
  357.       IVQD(NVQD)=ISEGNO(ITMP2,ITMP3)
  358.       VQD(NVQD)=DCMPLX(TMP1,TMP2)
  359.       IF(ABS(VQD(NVQD)).LT.1.D-20)VQD(NVQD)=(1.,0.)
  360.       GO TO 207
  361. 205   NSANT=NSANT+1
  362.       IF (NSANT.LE.NSMAX) GO TO 26
  363. 206   WRITE(3,141)
  364.       STOP
  365. 26    ISANT(NSANT)=ISEGNO(ITMP2,ITMP3)
  366.       VSANT(NSANT)=DCMPLX(TMP1,TMP2)
  367.       IF (ABS(VSANT(NSANT)).LT.1.D-20) VSANT(NSANT)=(1.,0.)
  368. 207   IPED=ITMP4-MASYM*10
  369.       ZPNORM=TMP3
  370.       IF (IPED.EQ.1.AND.ZPNORM.GT.0) IPED=2
  371.       GO TO 14
  372. 27    IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) NTSOL=0
  373.       IXTYP=ITMP1
  374.       NTHI=ITMP2
  375.       NPHI=ITMP3
  376.       XPR1=TMP1
  377.       XPR2=TMP2
  378.       XPR3=TMP3
  379.       XPR4=TMP4
  380.       XPR5=TMP5
  381.       XPR6=TMP6
  382.       NSANT=0
  383.       NVQD=0
  384.       THETIS=XPR1
  385.       PHISS=XPR2
  386.       GO TO 14
  387. C
  388. C     NETWORK PARAMETERS
  389. C
  390. 28    IF (IFLOW.EQ.6) GO TO 29
  391.       NONET=0
  392.       NTSOL=0
  393.       IFLOW=6
  394.       IF (IGO.GT.3) IGO=3
  395.       IF (ITMP2.EQ.(-1)) GO TO 14
  396. 29    NONET=NONET+1
  397.       IF (NONET.LE.NETMX) GO TO 30
  398.       WRITE(3,142)
  399.       STOP
  400. 30    NTYP(NONET)=2
  401.       IF (AIN.EQ.ATST(6)) NTYP(NONET)=1
  402.       ISEG1(NONET)=ISEGNO(ITMP1,ITMP2)
  403.       ISEG2(NONET)=ISEGNO(ITMP3,ITMP4)
  404.       X11R(NONET)=TMP1
  405.       X11I(NONET)=TMP2
  406.       X12R(NONET)=TMP3
  407.       X12I(NONET)=TMP4
  408.       X22R(NONET)=TMP5
  409.       X22I(NONET)=TMP6
  410.       IF (NTYP(NONET).EQ.1.OR.TMP1.GT.0.) GO TO 14
  411.       NTYP(NONET)=3
  412.       X11R(NONET)=-TMP1
  413.       GO TO 14
  414. C***
  415. C
  416. C     PLOT FLAGS
  417. C
  418. 330   IPLP1=ITMP1
  419.       IPLP2=ITMP2
  420.       IPLP3=ITMP3
  421.       IPLP4=ITMP4
  422. C***
  423.       GO TO 14
  424. C
  425. C     PRINT CONTROL FOR CURRENT
  426. C
  427. 31    IPTFLG=ITMP1
  428.       IPTAG=ITMP2
  429.       IPTAGF=ITMP3
  430.       IPTAGT=ITMP4
  431.       IF(ITMP3.EQ.0.AND.IPTFLG.NE.-1)IPTFLG=-2
  432.       IF (ITMP4.EQ.0) IPTAGT=IPTAGF
  433.       GO TO 14
  434. C
  435. C     WRITE CONTROL FOR CHARGE
  436. C
  437. 319   IPTFLQ=ITMP1
  438.       IPTAQ=ITMP2
  439.       IPTAQF=ITMP3
  440.       IPTAQT=ITMP4
  441.       IF(ITMP3.EQ.0.AND.IPTFLQ.NE.-1)IPTFLQ=-2
  442.       IF(ITMP4.EQ.0)IPTAQT=IPTAQF
  443.       GO TO 14
  444. C
  445. C     NEAR FIELD CALCULATION PARAMETERS
  446. C
  447. 208   NFEH=1
  448.       GO TO 209
  449. 32    NFEH=0
  450. 209   IF (.NOT.(IFLOW.EQ.8.AND.NFRQ.NE.1)) GO TO 33
  451.       WRITE(3,143)
  452. 33    NEAR=ITMP1
  453.       NRX=ITMP2
  454.       NRY=ITMP3
  455.       NRZ=ITMP4
  456.       XNR=TMP1
  457.       YNR=TMP2
  458.       ZNR=TMP3
  459.       DXNR=TMP4
  460.       DYNR=TMP5
  461.       DZNR=TMP6
  462.       IFLOW=8
  463.       IF (NFRQ.NE.1) GO TO 14
  464.       GO TO (41,46,53,71,72), IGO
  465. C
  466. C     GROUND REPRESENTATION
  467. C
  468. 34    EPSR2=TMP1
  469.       SIG2=TMP2
  470.       CLT=TMP3
  471.       CHT=TMP4
  472.       IFLOW=9
  473.       GO TO 14
  474. C
  475. C     STANDARD OBSERVATION ANGLE PARAMETERS
  476. C
  477. 36    IFAR=ITMP1
  478.       NTH=ITMP2
  479.       NPH=ITMP3
  480.       IF (NTH.EQ.0) NTH=1
  481.       IF (NPH.EQ.0) NPH=1
  482.       IPD=ITMP4/10
  483.       IAVP=ITMP4-IPD*10
  484.       INOR=IPD/10
  485.       IPD=IPD-INOR*10
  486.       IAX=INOR/10
  487.       INOR=INOR-IAX*10
  488.       IF (IAX.NE.0) IAX=1
  489.       IF (IPD.NE.0) IPD=1
  490.       IF (NTH.LT.2.OR.NPH.LT.2) IAVP=0
  491.       IF (IFAR.EQ.1) IAVP=0
  492.       THETS=TMP1
  493.       PHIS=TMP2
  494.       DTH=TMP3
  495.       DPH=TMP4
  496.       RFLD=TMP5
  497.       GNOR=TMP6
  498.       IFLOW=10
  499.       GO TO (41,46,53,71,78), IGO
  500. C
  501. C     WRITE NUMERICAL GREEN'S FUNCTION TAPE
  502. C
  503. 322   IFLOW=12
  504.       IF(ICASX.EQ.0)GO TO 301
  505.       WRITE(3,302)
  506.       STOP
  507. 301   IRNGF=IRESRV/2
  508.       GO TO (41,46,52,52,52),IGO
  509. C
  510. C     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDS
  511. C
  512. 37    IF (IFLOW.EQ.10.AND.ITMP1.EQ.0) GO TO 14
  513.       IF (NFRQ.EQ.1.AND.ITMP1.EQ.0.AND.IFLOW.GT.7) GO TO 14
  514.       IF (ITMP1.NE.0) GO TO 39
  515.       IF (IFLOW.GT.7) GO TO 38
  516.       IFLOW=7
  517.       GO TO 40
  518. 38    IFLOW=11
  519.       GO TO 40
  520. 39    IFAR=0
  521.       RFLD=0.
  522.       IPD=0
  523.       IAVP=0
  524.       INOR=0
  525.       IAX=0
  526.       NTH=91
  527.       NPH=1
  528.       THETS=0.
  529.       PHIS=0.
  530.       DTH=1.0
  531.       DPH=0.
  532.       IF (ITMP1.EQ.2) PHIS=90.
  533.       IF (ITMP1.NE.3) GO TO 40
  534.       NPH=2
  535.       DPH=90.
  536. 40    GO TO (41,46,53,71,78), IGO
  537. C
  538. C     END OF THE MAIN INPUT SECTION
  539. C
  540. C     BEGINNING OF THE FREQUENCY DO LOOP
  541. C
  542. 41    MHZ=1
  543. C***
  544.         IF(N.EQ.0 .OR. IFRTIMW .EQ. 1)GO TO 406
  545.         IFRTIMW=1
  546.         DO 445 I=1,N
  547.            XTEMP(I)=X(I)
  548.            YTEMP(I)=Y(I)
  549.            ZTEMP(I)=Z(I)
  550.            SITEMP(I)=SI(I)
  551.            BITEMP(I)=BI(I)
  552. 445     CONTINUE
  553. 406     IF(M.EQ.0 .OR. IFRTIMP .EQ. 1)GO TO 407
  554.         IFRTIMP=1
  555.         J=LD+1
  556.         DO 545 I=1,M
  557.            J=J-1
  558.            XTEMP(J)=X(J)
  559.            YTEMP(J)=Y(J)
  560.            ZTEMP(J)=Z(J)
  561.            BITEMP(J)=BI(J)
  562. 545     CONTINUE
  563. 407     CONTINUE
  564.         FMHZ1=FMHZ
  565. C***
  566. C     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A)
  567.       IF(IMAT.EQ.0)CALL FBLOCK(NPEQ,NEQ,IRESRV,IRNGF,IPSYM)
  568. 42    IF (MHZ.EQ.1) GO TO 44
  569.       IF (IFRQ.EQ.1) GO TO 43
  570. C      FMHZ=FMHZ+DELFRQ
  571. C***
  572.       FMHZ=FMHZ1+(MHZ-1)*DELFRQ
  573.       GO TO 44
  574. 43    FMHZ=FMHZ*DELFRQ
  575. 44    FR=FMHZ/CVEL
  576. C***
  577.       WLAM=CVEL/FMHZ
  578.       WRITE(3,145)  FMHZ,WLAM
  579.       WRITE(3,196) RKH
  580.       IF(IEXK.EQ.1)WRITE(3,321)
  581. C     FREQUENCY SCALING OF GEOMETRIC PARAMETERS
  582. C***      FMHZS=FMHZ
  583.       IF(N.EQ.0)GO TO 306
  584.       DO 45 I=1,N
  585. C***
  586.       X(I)=XTEMP(I)*FR
  587.       Y(I)=YTEMP(I)*FR
  588.       Z(I)=ZTEMP(I)*FR
  589.       SI(I)=SITEMP(I)*FR
  590. 45    BI(I)=BITEMP(I)*FR
  591. C***
  592. 306   IF(M.EQ.0)GO TO 307
  593.       FR2=FR*FR
  594.       J=LD+1
  595.       DO 245 I=1,M
  596.       J=J-1
  597. C***
  598.       X(J)=XTEMP(J)*FR
  599.       Y(J)=YTEMP(J)*FR
  600.       Z(J)=ZTEMP(J)*FR
  601. 245   BI(J)=BITEMP(J)*FR2
  602. C***
  603. 307   IGO=2
  604. C     STRUCTURE SEGMENT LOADING
  605. 46    WRITE(3,146)
  606.       IF(NLOAD.NE.0) CALL LOAD(LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC)
  607.       IF(NLOAD.EQ.0.AND.NLODF.EQ.0)WRITE(3,147)
  608.       IF(NLOAD.EQ.0.AND.NLODF.NE.0)WRITE(3,327)
  609. C     GROUND PARAMETER
  610.       WRITE(3,148)
  611.       IF (KSYMP.EQ.1) GO TO 49
  612.       FRATI=(1.,0.)
  613.       IF (IPERF.EQ.1) GO TO 48
  614.       IF(SIG.LT.0.)SIG=-SIG/(59.96*WLAM)
  615.       EPSC=DCMPLX(EPSR,-SIG*WLAM*59.96)
  616.       ZRATI=1./SQRT(EPSC)
  617.       U=ZRATI
  618.       U2=U*U
  619.       IF (NRADL.EQ.0) GO TO 47
  620.       SCRWL=SCRWLT/WLAM
  621.       SCRWR=SCRWRT/WLAM
  622.       T1=FJ*2367.067D+0/DFLOAT(NRADL)
  623.       T2=SCRWR*DFLOAT(NRADL)
  624.       WRITE(3,170)  NRADL,SCRWLT,SCRWRT
  625.       WRITE(3,149)
  626. 47    IF(IPERF.EQ.2)GO TO 328
  627.       WRITE(3,391)
  628.       GO TO 329
  629. 328   IF(NXA(1).EQ.0)THEN
  630.          OPEN(UNIT=21,FILE='SOM2D.NEC',STATUS='OLD',FORM='UNFORMATTED',
  631.      &   ERR=800)
  632.          GO TO 801
  633. 800      WRITE(3,900)
  634.          STOP
  635. 801      READ(21)AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA,NYA
  636.       END IF
  637.       FRATI=(EPSC-1.)/(EPSC+1.)
  638.       IF(ABS((EPSCF-EPSC)/EPSC).LT.1.D-3)GO TO 400
  639.       WRITE(3,393) EPSCF,EPSC
  640.       STOP
  641. 400   WRITE(3,392)
  642. 329   WRITE(3,150)  EPSR,SIG,EPSC
  643.       GO TO 50
  644. 48    WRITE(3,151)
  645.       GO TO 50
  646. 49    WRITE(3,152)
  647. 50    CONTINUE
  648. C * * *
  649. C     FILL AND FACTOR PRIMARY INTERACTION MATRIX
  650. C
  651.       CALL SECOND (TIM1)
  652.       IF(ICASX.NE.0)GO TO 324
  653.       CALL CMSET(NEQ,CM,RKH,IEXK)
  654.       CALL SECOND (TIM2)
  655.       TIM=TIM2-TIM1
  656.       CALL FACTRS(NPEQ,NEQ,CM,IP,IX,11,12,13,14)
  657.       GO TO 323
  658. C
  659. C     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)
  660. C
  661. C ****
  662. 324   IF(NEQ2.EQ.0)GO TO 333
  663. C ****
  664.       CALL CMNGF(CM(IB11),CM(IC11),CM(ID11),NPBX,NEQ,NEQ2,RKH,IEXK)
  665.       CALL SECOND (TIM2)
  666.       TIM=TIM2-TIM1
  667.       CALL FACGF(CM,CM(IB11),CM(IC11),CM(ID11),CM(IX11),IP,IX,NP,N1,MP,
  668.      1M1,NEQ,NEQ2)
  669. 323   CALL SECOND (TIM1)
  670.       TIM2=TIM1-TIM2
  671.       WRITE(3,153)  TIM,TIM2
  672. 333   IGO=3
  673.       NTSOL=0
  674.       IF(IFLOW.NE.12)GO TO 53
  675. C     WRITE N.G.F. FILE
  676. 52    CALL GFOUT
  677.       GO TO 14
  678. C
  679. C     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)
  680. C
  681. 53    NTHIC=1
  682.       NPHIC=1
  683.       INC=1
  684.       NPRINT=0
  685. 54    IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 56
  686.       IF (IPTFLG.LE.0.OR.IXTYP.EQ.4) WRITE(3,154)
  687.       TMP5=TA*XPR5
  688.       TMP4=TA*XPR4
  689.       IF (IXTYP.NE.4) GO TO 55
  690.       TMP1=XPR1/WLAM
  691.       TMP2=XPR2/WLAM
  692.       TMP3=XPR3/WLAM
  693.       TMP6=XPR6/(WLAM*WLAM)
  694.       WRITE(3,156)  XPR1,XPR2,XPR3,XPR4,XPR5,XPR6
  695.       GO TO 56
  696. 55    TMP1=TA*XPR1
  697.       TMP2=TA*XPR2
  698.       TMP3=TA*XPR3
  699.       TMP6=XPR6
  700.       IF (IPTFLG.LE.0) WRITE(3,155)  XPR1,XPR2,XPR3,HPOL(IXTYP),XPR6
  701. 56    CALL ETMNS (TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,IXTYP,CUR)
  702. C
  703. C     MATRIX SOLVING  (NETWK CALLS SOLVES)
  704. C
  705.       IF (NONET.EQ.0.OR.INC.GT.1) GO TO 60
  706.       WRITE(3,158)
  707.       ITMP3=0
  708.       ITMP1=NTYP(1)
  709.       DO 59 I=1,2
  710.       IF (ITMP1.EQ.3) ITMP1=2
  711.       IF (ITMP1.EQ.2) WRITE(3,159)
  712.       IF (ITMP1.EQ.1) WRITE(3,160)
  713.       DO 58 J=1,NONET
  714.       ITMP2=NTYP(J)
  715.       IF ((ITMP2/ITMP1).EQ.1) GO TO 57
  716.       ITMP3=ITMP2
  717.       GO TO 58
  718. 57    ITMP4=ISEG1(J)
  719.       ITMP5=ISEG2(J)
  720.       IF (ITMP2.GE.2.AND.X11I(J).LE.0.) X11I(J)=WLAM*SQRT((X(ITMP5)-
  721.      1 X(ITMP4))**2+(Y(ITMP5)-Y(ITMP4))**2+(Z(ITMP5)-Z(ITMP4))**2)
  722.       WRITE(3,157)  ITAG(ITMP4),ITMP4,ITAG(ITMP5),ITMP5,X11R(J),X11
  723.      1I(J),X12R(J),X12I(J),X22R(J),X22I(J),PNET(2*ITMP2-1),PNET(2*ITMP2)
  724. 58    CONTINUE
  725.       IF (ITMP3.EQ.0) GO TO 60
  726.       ITMP1=ITMP3
  727. 59    CONTINUE
  728. 60    CONTINUE
  729.       IF (INC.GT.1.AND.IPTFLG.GT.0) NPRINT=1
  730.       CALL NETWK(CM,CM(IB11),CM(IC11),CM(ID11),IP,CUR)
  731.       NTSOL=1
  732.       IF (IPED.EQ.0) GO TO 61
  733.       ITMP1=MHZ+4*(MHZ-1)
  734.       IF (ITMP1.GT.(NORMF-3)) GO TO 61
  735.       FNORM(ITMP1)=DREAL(ZPED)
  736.       FNORM(ITMP1+1)=DIMAG(ZPED)
  737.       FNORM(ITMP1+2)=ABS(ZPED)
  738.       FNORM(ITMP1+3)=CANG(ZPED)
  739.       IF (IPED.EQ.2) GO TO 61
  740.       IF (FNORM(ITMP1+2).GT.ZPNORM) ZPNORM=FNORM(ITMP1+2)
  741. 61    CONTINUE
  742. C
  743. C     PRINTING STRUCTURE CURRENTS
  744. C
  745.       IF(N.EQ.0)GO TO 308
  746.       IF (IPTFLG.EQ.(-1)) GO TO 63
  747.       IF (IPTFLG.GT.0) GO TO 62
  748.       WRITE(3,161)
  749.       WRITE(3,162)
  750.       GO TO 63
  751. 62    IF (IPTFLG.EQ.3.OR.INC.GT.1) GO TO 63
  752.       WRITE(3,163)  XPR3,HPOL(IXTYP),XPR6
  753. 63    PLOSS=0.
  754.       ITMP1=0
  755.       JUMP=IPTFLG+1
  756.       DO 69 I=1,N
  757.       CURI=CUR(I)*WLAM
  758.       CMAG=ABS(CURI)
  759.       PH=CANG(CURI)
  760.       IF (NLOAD.EQ.0.AND.NLODF.EQ.0) GO TO 64
  761.       IF (ABS(DREAL(ZARRAY(I))).LT.1.D-20) GO TO 64
  762.       PLOSS=PLOSS+.5*CMAG*CMAG*DREAL(ZARRAY(I))*SI(I)
  763. 64    IF (JUMP) 68,69,65
  764. 65    IF (IPTAG.EQ.0) GO TO 66
  765.       IF (ITAG(I).NE.IPTAG) GO TO 69
  766. 66    ITMP1=ITMP1+1
  767.       IF (ITMP1.LT.IPTAGF.OR.ITMP1.GT.IPTAGT) GO TO 69
  768.       IF (IPTFLG.EQ.0) GO TO 68
  769.       IF (IPTFLG.LT.2.OR.INC.GT.NORMF) GO TO 67
  770.       FNORM(INC)=CMAG
  771.       ISAVE=I
  772. 67    IF (IPTFLG.NE.3) WRITE(3,164)  XPR1,XPR2,CMAG,PH,I
  773.       GO TO 69
  774. 68    WRITE(3,165)  I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH
  775. C***
  776.       IF(IPLP1 .NE. 1) GO TO 69
  777.       IF(IPLP2 .EQ. 1) WRITE(8,*) CURI
  778.       IF(IPLP2 .EQ. 2) WRITE(8,*) CMAG,PH
  779. C***
  780. 69    CONTINUE
  781.       IF(IPTFLQ.EQ.(-1))GO TO 308
  782.       WRITE(3,315)
  783.       ITMP1=0
  784.       FR=1.D-6/FMHZ
  785.       DO 316 I=1,N
  786.       IF(IPTFLQ.EQ.(-2))GO TO 318
  787.       IF(IPTAQ.EQ.0)GO TO 317
  788.       IF(ITAG(I).NE.IPTAQ)GO TO 316
  789. 317   ITMP1=ITMP1+1
  790.       IF(ITMP1.LT.IPTAQF.OR.ITMP1.GT.IPTAQT)GO TO 316
  791. 318   CURI=FR*DCMPLX(-BII(I),BIR(I))
  792.       CMAG=ABS(CURI)
  793.       PH=CANG(CURI)
  794.       WRITE(3,165) I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH
  795. 316   CONTINUE
  796. 308   IF(M.EQ.0)GO TO 310
  797.       WRITE(3,197)
  798.       J=N-2
  799.       ITMP1=LD+1
  800.       DO 309 I=1,M
  801.       J=J+3
  802.       ITMP1=ITMP1-1
  803.       EX=CUR(J)
  804.       EY=CUR(J+1)
  805.       EZ=CUR(J+2)
  806.       ETH=EX*T1X(ITMP1)+EY*T1Y(ITMP1)+EZ*T1Z(ITMP1)
  807.       EPH=EX*T2X(ITMP1)+EY*T2Y(ITMP1)+EZ*T2Z(ITMP1)
  808.       ETHM=ABS(ETH)
  809.       ETHA=CANG(ETH)
  810.       EPHM=ABS(EPH)
  811.       EPHA=CANG(EPH)
  812. C309   WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E
  813. C     1X,EY, EZ
  814. C***
  815.       WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E
  816.      1X,EY,EZ
  817.       IF(IPLP1 .NE. 1) GO TO 309
  818.       IF(IPLP3 .EQ. 1) WRITE(8,*) EX
  819.       IF(IPLP3 .EQ. 2) WRITE(8,*) EY
  820.       IF(IPLP3 .EQ. 3) WRITE(8,*) EZ
  821.       IF(IPLP3 .EQ. 4) WRITE(8,*) EX,EY,EZ
  822. 309   CONTINUE
  823. C***
  824. 310   IF (IXTYP.NE.0.AND.IXTYP.NE.5) GO TO 70
  825.       TMP1=PIN-PNLS-PLOSS
  826.       TMP2=100.*TMP1/PIN
  827.       WRITE(3,166)  PIN,TMP1,PLOSS,PNLS,TMP2
  828. 70    CONTINUE
  829.       IGO=4
  830.       IF(NCOUP.GT.0)CALL COUPLE(CUR,WLAM)
  831.       IF (IFLOW.NE.7) GO TO 71
  832.       IF (IXTYP.GT.0.AND.IXTYP.LT.4) GO TO 113
  833.       IF (NFRQ.NE.1) GO TO 120
  834.       WRITE(3,135)
  835.       GO TO 14
  836. 71    IGO=5
  837. C
  838. C     NEAR FIELD CALCULATION
  839. C
  840. 72    IF (NEAR.EQ.(-1)) GO TO 78
  841.       CALL NFPAT
  842.       IF (MHZ.EQ.NFRQ) NEAR=-1
  843.       IF (NFRQ.NE.1) GO TO 78
  844.       WRITE(3,135)
  845.       GO TO 14
  846. C
  847. C     STANDARD FAR FIELD CALCULATION
  848. C
  849. 78    IF(IFAR.EQ.-1)GO TO 113
  850.       PINR=PIN
  851.       PNLR=PNLS
  852.       CALL RDPAT
  853. 113   IF (IXTYP.EQ.0.OR.IXTYP.GE.4) GO TO 119
  854.       NTHIC=NTHIC+1
  855.       INC=INC+1
  856.       XPR1=XPR1+XPR4
  857.       IF (NTHIC.LE.NTHI) GO TO 54
  858.       NTHIC=1
  859.       XPR1=THETIS
  860.       XPR2=XPR2+XPR5
  861.       NPHIC=NPHIC+1
  862.       IF (NPHIC.LE.NPHI) GO TO 54
  863.       NPHIC=1
  864.       XPR2=PHISS
  865.       IF (IPTFLG.LT.2) GO TO 119
  866. C     NORMALIZED RECEIVING PATTERN PRINTED
  867.       ITMP1=NTHI*NPHI
  868.       IF (ITMP1.LE.NORMF) GO TO 114
  869.       ITMP1=NORMF
  870.       WRITE(3,181)
  871. 114   TMP1=FNORM(1)
  872.       DO 115 J=2,ITMP1
  873.       IF (FNORM(J).GT.TMP1) TMP1=FNORM(J)
  874. 115   CONTINUE
  875.       WRITE(3,182)  TMP1,XPR3,HPOL(IXTYP),XPR6,ISAVE
  876.       DO 118 J=1,NPHI
  877.       ITMP2=NTHI*(J-1)
  878.       DO 116 I=1,NTHI
  879.       ITMP3=I+ITMP2
  880.       IF (ITMP3.GT.ITMP1) GO TO 117
  881.       TMP2=FNORM(ITMP3)/TMP1
  882.       TMP3=DB20(TMP2)
  883.       WRITE(3,183)  XPR1,XPR2,TMP3,TMP2
  884.       XPR1=XPR1+XPR4
  885. 116   CONTINUE
  886. 117   XPR1=THETIS
  887.       XPR2=XPR2+XPR5
  888. 118   CONTINUE
  889.       XPR2=PHISS
  890. 119   IF (MHZ.EQ.NFRQ) IFAR=-1
  891.       IF (NFRQ.NE.1) GO TO 120
  892.       WRITE(3,135)
  893.       GO TO 14
  894. 120   MHZ=MHZ+1
  895.       IF (MHZ.LE.NFRQ) GO TO 42
  896.       IF (IPED.EQ.0) GO TO 123
  897.       IF(NVQD.LT.1)GO TO 199
  898.       WRITE(3,184) IVQD(NVQD),ZPNORM
  899.       GO TO 204
  900. 199   WRITE(3,184)  ISANT(NSANT),ZPNORM
  901. 204   ITMP1=NFRQ
  902.       IF (ITMP1.LE.(NORMF/4)) GO TO 121
  903.       ITMP1=NORMF/4
  904.       WRITE(3,185)
  905. 121   IF (IFRQ.EQ.0) TMP1=FMHZ-(NFRQ-1)*DELFRQ
  906.       IF (IFRQ.EQ.1) TMP1=FMHZ/(DELFRQ**(NFRQ-1))
  907.       DO 122 I=1,ITMP1
  908.       ITMP2=I+4*(I-1)
  909.       TMP2=FNORM(ITMP2)/ZPNORM
  910.       TMP3=FNORM(ITMP2+1)/ZPNORM
  911.       TMP4=FNORM(ITMP2+2)/ZPNORM
  912.       TMP5=FNORM(ITMP2+3)
  913.       WRITE(3,186)  TMP1,FNORM(ITMP2),FNORM(ITMP2+1),FNORM(ITMP2+2),
  914.      1FNORM(ITMP2+3),TMP2,TMP3,TMP4,TMP5
  915.       IF (IFRQ.EQ.0) TMP1=TMP1+DELFRQ
  916.       IF (IFRQ.EQ.1) TMP1=TMP1*DELFRQ
  917. 122   CONTINUE
  918.       WRITE(3,135)
  919. 123   CONTINUE
  920.       NFRQ=1
  921.       MHZ=1
  922.       GO TO 14
  923. 125   FORMAT (A2,19A4)
  924. 126   FORMAT  (1H1)
  925. 127   FORMAT (///,33X,'*********************************************',
  926.      &//,36X,'NUMERICAL ELECTROMAGNETICS CODE (NEC-2D)',//,33X,
  927.      2 '*********************************************')
  928. 128   FORMAT (////,37X,24H- - - - COMMENTS - - - -,//)
  929. 129   FORMAT (25X,20A4)
  930. 130   FORMAT (///,10X,34HINCORRECT LABEL FOR A COMMENT CARD)
  931. 135   FORMAT (/////)
  932. 136   FORMAT (A2,I3,3I5,6E10.3)
  933. 137   FORMAT (1X, 19H***** DATA CARD NO.,I3,3X,A2,1X,I3,3(1X,I5),
  934.      1 6(1X,1P,E12.5))
  935. 138   FORMAT (///,10X,45HFAULTY DATA CARD LABEL AFTER GEOMETRY SECTION)
  936. 139   FORMAT (///,10X,48HNUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTE
  937.      1D)
  938. 140   FORMAT (///,10X,31HDATA FAULT ON LOADING CARD NO.=,I5,5X,11HITAG S
  939.      1TEP1=,I5,29H  IS GREATER THAN ITAG STEP2=,I5)
  940. 141   FORMAT (///,10X,51HNUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO
  941.      1TTED)
  942. 142   FORMAT (///,10X,48HNUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTE
  943.      1D)
  944. 143   FORMAT(///,10X,79HWHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ON
  945.      1E NEAR FIELD CARD CAN BE USED -,/,10X,22HLAST CARD READ IS USED)
  946. 145   FORMAT (////,33X,33H- - - - - - FREQUENCY - - - - - -,//,36X,10HFR
  947.      1EQUENCY=,1P,E11.4,4H MHZ,/,36X,11HWAVELENGTH=,E11.4,7H METERS)
  948. 146   FORMAT (///,30X,40H - - - STRUCTURE IMPEDANCE LOADING - - -)
  949. 147   FORMAT (/ ,35X,28HTHIS STRUCTURE IS NOT LOADED)
  950. 148   FORMAT (///,34X,31H- - - ANTENNA ENVIRONMENT - - -,/)
  951. 149   FORMAT (40X,21HMEDIUM UNDER SCREEN -)
  952. 150   FORMAT (40X,27HRELATIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIV
  953.      1ITY=,1P,E10.3,11H MHOS/METER,/,40X,28HCOMPLEX DIELECTRIC CONSTANT=
  954.      1,2E12.5)
  955. 151   FORMAT (  42X,14HPERFECT GROUND)
  956. 152   FORMAT (  44X,10HFREE SPACE)
  957. 153   FORMAT (///,32X,25H- - - MATRIX TIMING - - -,//,24X,5HFILL=,F9.3,
  958.      115H SEC.,  FACTOR=,F9.3,5H SEC.)
  959. 154   FORMAT (///,40X,22H- - - EXCITATION - - -)
  960. 155   FORMAT (/,4X,10HPLANE WAVE,4X,6HTHETA=,F7.2,11H DEG,  PHI=,F7.2,
  961.      1 11H DEG,  ETA=,F7.2,13H DEG,  TYPE -,A6,15H=  AXIAL RATIO=,F6.3)
  962. 156   FORMAT (/,31X,17HPOSITION (METERS),14X,18HORIENTATION (DEG)=/,28X,
  963.      11HX,12X,1HY,12X,1HZ,10X,5HALPHA,5X,4HBETA,4X,13HDIPOLE MOMENT,//
  964.      2 ,4X,14HCURRENT SOURCE,1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3)
  965. 157   FORMAT (4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2)
  966. 158   FORMAT (///,44X,24H- - - NETWORK DATA - - -)
  967. 159   FORMAT (/,6X,18H- FROM -    - TO -,11X,17HTRANSMISSION LINE,15X,36
  968.      1H-  -  SHUNT ADMITTANCES (MHOS)  -  -,14X,4HLINE,/,6X,21HTAG  SEG.
  969.      2   TAG  SEG.,6X,9HIMPEDANCE,6X,6HLENGTH,12X,11H- END ONE -,17X,11H
  970.      3- END TWO -,12X,4HTYPE,/    ,6X,21HNO.   NO.   NO.   NO.,9X,4HOHMS
  971.      4,8X,6HMETERS,9X, 4HREAL,10X,5HIMAG.,9X,4HREAL,10X,5HIMAG.)
  972. 160   FORMAT (/,6X,8H- FROM -,4X,6H- TO -,26X,45H-  -  ADMITTANCE MATRIX
  973.      1 ELEMENTS (MHOS)  -  -,/    ,6X,21HTAG  SEG.   TAG  SEG.,13X,9H(ON
  974.      2E,ONE),19X,    9H(ONE,TWO),19X,9H(TWO,TWO),/ ,6X,21HNO.   NO.   NO
  975.      3.   NO.,8X,4HREAL,10X,5HIMAG.,9X,4HREAL,10X,5HIMAG.,9X,4HREAL,
  976.      4 10X,5HIMAG.)
  977. 161   FORMAT (///,29X,33H- - - CURRENTS AND LOCATION - - -,//,33X,24HDIS
  978.      1TANCES IN WAVELENGTHS)
  979. 162   FORMAT (  //,2X,4HSEG.,2X,3HTAG,4X,21HCOORD. OF SEG. CENTER,5X,
  980.      1 4HSEG.,12X,26H- - - CURRENT (AMPS) - - -,/,2X,3HNO.,3X,3HNO.,
  981.      2 5X,1HX,8X,1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,
  982.      3 8X,5HPHASE)
  983. 163   FORMAT (///,33X,40H- - - RECEIVING PATTERN PARAMETERS - - -,/  ,43
  984.      1X,4HETA=,F7.2,8H DEGREES,/,43X,6HTYPE -,A6,/,43X,12HAXIAL RATIO=,
  985.      2 F6.3,//   ,11X,5HTHETA,6X,3HPHI,10X,13H-  CURRENT  -,9X,3HSEG,/
  986.      3,11X,5H(DEG),5X,5H(DEG),7X,9HMAGNITUDE,4X,5HPHASE,6X,3HNO.,/)
  987. 164   FORMAT (10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5)
  988. 165   FORMAT (1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3)
  989. 166   FORMAT (///,40X,24H- - - POWER BUDGET - - -,//    ,43X,15HINPUT PO
  990.      1WER   =,1P,E11.4,6H WATTS,/ ,43X,15HRADIATED POWER=,E11.4,6H WATTS
  991.      2,/,43X,15HSTRUCTURE LOSS=,E11.4,6H WATTS,/ ,43X,15HNETWORK LOSS  =
  992.      3, E11.4,6H WATTS,/,43X,15HEFFICIENCY    =,0P,F7.2,8H PERCENT)
  993. 170   FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,   I5,6H WIRES,/,40
  994.      1X,12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3,
  995.      27H METERS)
  996. 181   FORMAT (///,4X,51HRECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA
  997.      1TED)
  998. 182   FORMAT (///,32X,40H- - - NORMALIZED RECEIVING PATTERN - - -,/,41X,
  999.      121HNORMALIZATION FACTOR=,1P,E11.4,/,41X,4HETA=,0P,F7.2,8H DEGREES,
  1000.      2/,41X,6HTYPE -,A6,/,41X,12HAXIAL RATIO=,F6.3,/,41X,12HSEGMENT NO.=
  1001.      3,I5,//,21X,5HTHETA,6X,3HPHI,9X,13H-  PATTERN  -,/,21X,5H(DEG),5X,
  1002.      45H(DEG),8X,2HDB,8X,9HMAGNITUDE,/)
  1003. 183   FORMAT (20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)
  1004. 184   FORMAT (///,36X,32H- - - INPUT IMPEDANCE DATA - - -,/   ,45X,18HSO
  1005.      1URCE SEGMENT NO.,I4,/  ,45X,21HNORMALIZATION FACTOR=,1P,E12.5,//
  1006.      2,7X,5HFREQ.,13X,34H-  -  UNNORMALIZED IMPEDANCE  -  -,21X,   32H- 
  1007.      3 -  NORMALIZED IMPEDANCE  -  -,/    ,19X,10HRESISTANCE,4X,9HREACTA
  1008.      4NCE,6X,9HMAGNITUDE,4X,5HPHASE,7X,10HRESISTANCE,4X,9HREACTANCE,6X,
  1009.      5 9HMAGNITUDE,4X,5HPHASE,/    ,8X,3HMHZ,11X,4HOHMS,10X,4HOHMS,11X,
  1010.      6 4HOHMS,5X,7HDEGREES,47X,7HDEGREES,/)
  1011. 185   FORMAT (///,4X,62HSTORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A
  1012.      1RRAY TRUNCATED)
  1013. 186   FORMAT (3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,
  1014.      1 E12.5),3X,E12.5,2X,0P,F7.2)
  1015. 196   FORMAT(   ////,20X,55HAPPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT
  1016.      1S MORE THAN,F8.3,18H WAVELENGTHS APART)
  1017. 197   FORMAT(   ////,41X,38H- - - - SURFACE PATCH CURRENTS - - - -,//,
  1018.      1 50X,23HDISTANCE IN WAVELENGTHS,/,50X,21HCURRENT IN AMPS/METER,
  1019.      1 //,28X,26H- - SURFACE COMPONENTS - -,19X,34H- - - RECTANGULAR COM
  1020.      1PONENTS - - -,/,6X,12HPATCH CENTER,6X,16HTANGENT VECTOR 1,3X,
  1021.      116HTANGENT VECTOR 2,11X,1HX,19X,1HY,19X,1HZ,/,5X,1HX,6X,1HY,6X,
  1022.      11HZ,5X,4HMAG.,7X,5HPHASE,3X,4HMAG.,7X,5HPHASE,3(4X,4HREAL,6X,
  1023.      1 6HIMAG. ))
  1024. 198   FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)
  1025. 201   FORMAT(/,11H RUN TIME =,F10.3)
  1026. 315   FORMAT(///,34X,28H- - - CHARGE DENSITIES - - -,//,36X,
  1027.      1 24HDISTANCES IN WAVELENGTHS,///,2X,4HSEG.,2X,3HTAG,4X,
  1028.      2 21HCOORD. OF SEG. CENTER,5X,4HSEG.,10X,
  1029.      3 31HCHARGE DENSITY (COULOMBS/METER),/,2X,3HNO.,3X,3HNO.,5X,1HX,8X,
  1030.      4 1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,8X,5HPHASE)
  1031. 321   FORMAT( /,20X,42HTHE EXTENDED THIN WIRE KERNEL WILL BE USED)
  1032. 303   FORMAT(/,9H ERROR - ,A2,32H CARD IS NOT ALLOWED WITH N.G.F.)
  1033. 327   FORMAT(/,35X,31H LOADING ONLY IN N.G.F. SECTION)
  1034. 302   FORMAT(48H ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.)
  1035. 313   FORMAT(/,62H NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE
  1036.      1DS LIMIT)
  1037. 390   FORMAT(78H RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO
  1038.      1MMERFELD GROUND OPTION)
  1039. 391   FORMAT(40X,52HFINITE GROUND.  REFLECTION COEFFICIENT APPROXIMATION
  1040.      1)
  1041. 392   FORMAT(40X,35HFINITE GROUND.  SOMMERFELD SOLUTION)
  1042. 393   FORMAT(/,29H ERROR IN GROUND PARAMETERS -,/,41H COMPLEX DIELECTRIC
  1043.      1 CONSTANT FROM FILE IS,1P,2E12.5,/,32X,9HREQUESTED,2E12.5)
  1044. 900   FORMAT(' ERROR OPENING SOMMERFELD GROUND FILE - SOM2D.NEC')
  1045.       END
  1046.       SUBROUTINE ARC (ITG,NS,RADA,ANG1,ANG2,RAD)
  1047. C ***
  1048. C     DOUBLE PRECISION 6/4/85
  1049. C
  1050.       INCLUDE 'NEC2DPAR.INC'
  1051.       IMPLICIT REAL*8(A-H,O-Z)
  1052. C ***
  1053. C
  1054. C     ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS
  1055. C
  1056.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1057.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1058.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1059.      &IPSYM
  1060.       DIMENSION X2(1), Y2(1), Z2(1)
  1061.       EQUIVALENCE (X2,SI), (Y2,ALP), (Z2,BET)
  1062.       DATA TA/.01745329252D+0/
  1063.       IST=N+1
  1064.       N=N+NS
  1065.       NP=N
  1066.       MP=M
  1067.       IPSYM=0
  1068.       IF (NS.LT.1) RETURN
  1069.       IF (ABS(ANG2-ANG1).LT.360.00001D+0) GO TO 1
  1070.       WRITE(3,3)
  1071.       STOP
  1072. 1     ANG=ANG1*TA
  1073.       DANG=(ANG2-ANG1)*TA/NS
  1074.       XS1=RADA*COS(ANG)
  1075.       ZS1=RADA*SIN(ANG)
  1076.       DO 2 I=IST,N
  1077.       ANG=ANG+DANG
  1078.       XS2=RADA*COS(ANG)
  1079.       ZS2=RADA*SIN(ANG)
  1080.       X(I)=XS1
  1081.       Y(I)=0.
  1082.       Z(I)=ZS1
  1083.       X2(I)=XS2
  1084.       Y2(I)=0.
  1085.       Z2(I)=ZS2
  1086.       XS1=XS2
  1087.       ZS1=ZS2
  1088.       BI(I)=RAD
  1089. 2     ITAG(I)=ITG
  1090.       RETURN
  1091. C
  1092. 3     FORMAT (40H ERROR -- ARC ANGLE EXCEEDS 360. DEGREES)
  1093.       END
  1094.       FUNCTION ATGN2 (X,Y)
  1095. C ***
  1096. C     DOUBLE PRECISION 6/4/85
  1097. C
  1098.       IMPLICIT REAL*8(A-H,O-Z)
  1099. C ***
  1100. C
  1101. C     ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0.
  1102. C
  1103.       IF (X) 3,1,3
  1104. 1     IF (Y) 3,2,3
  1105. 2     ATGN2=0.
  1106.       RETURN
  1107. 3     ATGN2=ATAN2(X,Y)
  1108.       RETURN
  1109.       END
  1110.       SUBROUTINE BLCKOT (AR,NUNIT,IX1,IX2,NBLKS,NEOF)
  1111. C ***
  1112. C     DOUBLE PRECISION 6/4/85
  1113. C
  1114.       IMPLICIT REAL*8(A-H,O-Z)
  1115. C ***
  1116. C
  1117. C     BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES
  1118. C     FOR THE OUT-OF-CORE MATRIX SOLUTION.
  1119. C
  1120. C      LOGICAL ENF
  1121.       COMPLEX*16 AR
  1122.       DIMENSION AR(1)
  1123.       I1=(IX1+1)/2
  1124.       I2=(IX2+1)/2
  1125. 1     WRITE (NUNIT) (AR(J),J=I1,I2)
  1126.       RETURN
  1127.       ENTRY BLCKIN(AR,NUNIT,IX1,IX2,NBLKS,NEOF)
  1128.       I1=(IX1+1)/2
  1129.       I2=(IX2+1)/2
  1130.       DO 2 I=1,NBLKS
  1131.       READ (NUNIT,END=3) (AR(J),J=I1,I2)
  1132. C     IF (ENF(NUNIT)) GO TO 3
  1133. 2     CONTINUE
  1134.       RETURN
  1135. 3     WRITE(3,4)  NUNIT,NBLKS,NEOF
  1136.       IF (NEOF.NE.777) STOP
  1137.       NEOF=0
  1138.       RETURN
  1139. C
  1140. 4     FORMAT (13H  EOF ON UNIT,I3,9H  NBLKS= ,I3,8H  NEOF= ,I5)
  1141.       END
  1142.       SUBROUTINE CABC (CURX)
  1143. C ***
  1144. C     DOUBLE PRECISION 6/4/85
  1145. C
  1146.       INCLUDE 'NEC2DPAR.INC'
  1147.       IMPLICIT REAL*8(A-H,O-Z)
  1148. C ***
  1149. C
  1150. C     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
  1151. C     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
  1152. C     CURRENT VECTOR CUR.
  1153. C
  1154.       COMPLEX*16 CUR,CURX,VQDS,CURD,CCJ,VSANT,VQD,CS1,CS2
  1155.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1156.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1157.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1158.      &IPSYM
  1159.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  1160.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  1161.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1162.      1CON(10),NPCON
  1163.       COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
  1164.      130),NVQD,NSANT,NQDS
  1165.       COMMON /ANGL/ SALP(MAXSEG)
  1166.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1167.       DIMENSION CURX(1), CCJX(2)
  1168.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  1169.      12), (T2Z,ITAG)
  1170.       EQUIVALENCE (CCJ,CCJX)
  1171.       DATA TP/6.283185308D+0/,CCJX/0.,-0.01666666667D+0/
  1172.       IF (N.EQ.0) GO TO 6
  1173.       DO 1 I=1,N
  1174.       AIR(I)=0.
  1175.       AII(I)=0.
  1176.       BIR(I)=0.
  1177.       BII(I)=0.
  1178.       CIR(I)=0.
  1179. 1     CII(I)=0.
  1180.       DO 2 I=1,N
  1181.       AR=DREAL(CURX(I))
  1182.       AI=DIMAG(CURX(I))
  1183.       CALL TBF (I,1)
  1184.       DO 2 JX=1,JSNO
  1185.       J=JCO(JX)
  1186.       AIR(J)=AIR(J)+AX(JX)*AR
  1187.       AII(J)=AII(J)+AX(JX)*AI
  1188.       BIR(J)=BIR(J)+BX(JX)*AR
  1189.       BII(J)=BII(J)+BX(JX)*AI
  1190.       CIR(J)=CIR(J)+CX(JX)*AR
  1191. 2     CII(J)=CII(J)+CX(JX)*AI
  1192.       IF (NQDS.EQ.0) GO TO 4
  1193.       DO 3 IS=1,NQDS
  1194.       I=IQDS(IS)
  1195.       JX=ICON1(I)
  1196.       ICON1(I)=0
  1197.       CALL TBF (I,0)
  1198.       ICON1(I)=JX
  1199.       SH=SI(I)*.5
  1200.       CURD=CCJ*VQDS(IS)/((LOG(2.*SH/BI(I))-1.)*(BX(JSNO)*COS(TP*SH)+CX(
  1201.      1JSNO)*SIN(TP*SH))*WLAM)
  1202.       AR=DREAL(CURD)
  1203.       AI=DIMAG(CURD)
  1204.       DO 3 JX=1,JSNO
  1205.       J=JCO(JX)
  1206.       AIR(J)=AIR(J)+AX(JX)*AR
  1207.       AII(J)=AII(J)+AX(JX)*AI
  1208.       BIR(J)=BIR(J)+BX(JX)*AR
  1209.       BII(J)=BII(J)+BX(JX)*AI
  1210.       CIR(J)=CIR(J)+CX(JX)*AR
  1211. 3     CII(J)=CII(J)+CX(JX)*AI
  1212. 4     DO 5 I=1,N
  1213. 5     CURX(I)=DCMPLX(AIR(I)+CIR(I),AII(I)+CII(I))
  1214. 6     IF (M.EQ.0) RETURN
  1215. C     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
  1216.       K=LD-M
  1217.       JCO1=N+2*M+1
  1218.       JCO2=JCO1+M
  1219.       DO 7 I=1,M
  1220.       K=K+1
  1221.       JCO1=JCO1-2
  1222.       JCO2=JCO2-3
  1223.       CS1=CURX(JCO1)
  1224.       CS2=CURX(JCO1+1)
  1225.       CURX(JCO2)=CS1*T1X(K)+CS2*T2X(K)
  1226.       CURX(JCO2+1)=CS1*T1Y(K)+CS2*T2Y(K)
  1227. 7     CURX(JCO2+2)=CS1*T1Z(K)+CS2*T2Z(K)
  1228.       RETURN
  1229.       END
  1230.       FUNCTION CANG (Z)
  1231. C ***
  1232. C     DOUBLE PRECISION 6/4/85
  1233. C
  1234.       IMPLICIT REAL*8(A-H,O-Z)
  1235. C ***
  1236. C
  1237. C     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.
  1238. C
  1239.       COMPLEX*16 Z
  1240.       CANG=ATGN2(DIMAG(Z),DREAL(Z))*57.29577951D+0
  1241.       RETURN
  1242.       END
  1243.       SUBROUTINE CMNGF (CB,CC,CD,NB,NC,ND,RKHX,IEXKX)
  1244. C ***
  1245. C     DOUBLE PRECISION 6/4/85
  1246. C
  1247.       INCLUDE 'NEC2DPAR.INC'
  1248.       IMPLICIT REAL*8(A-H,O-Z)
  1249. C ***
  1250. C     CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION
  1251.       COMPLEX*16 CB,CC,CD,ZARRAY,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  1252.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1253.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1254.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1255.      &IPSYM
  1256.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  1257.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1258.      1CON(10),NPCON
  1259.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1260.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1261.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  1262.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  1263.       DIMENSION CB(NB,1), CC(NC,1), CD(ND,1)
  1264.       RKH=RKHX
  1265.       IEXK=IEXKX
  1266.       M1EQ=2*M1
  1267.       M2EQ=M1EQ+1
  1268.       MEQ=2*M
  1269.       NEQP=ND-NPCON*2
  1270.       NEQS=NEQP-NSCON
  1271.       NEQSP=NEQS+NC
  1272.       NEQN=NC+N-N1
  1273.       ITX=1
  1274.       IF (NSCON.GT.0) ITX=2
  1275.       IF (ICASX.EQ.1) GO TO 1
  1276.       REWIND 12
  1277.       REWIND 14
  1278.       REWIND 15
  1279.       IF (ICASX.GT.2) GO TO 5
  1280. 1     DO 4 J=1,ND
  1281.       DO 2 I=1,ND
  1282. 2     CD(I,J)=(0.,0.)
  1283.       DO 3 I=1,NB
  1284.       CB(I,J)=(0.,0.)
  1285. 3     CC(I,J)=(0.,0.)
  1286. 4     CONTINUE
  1287. 5     IST=N-N1+1
  1288.       IT=NPBX
  1289.       ISV=-NPBX
  1290. C     LOOP THRU 24 FILLS B.  FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS)
  1291.       DO 24 IBLK=1,NBBX
  1292.       ISV=ISV+NPBX
  1293.       IF (IBLK.EQ.NBBX) IT=NLBX
  1294.       IF (ICASX.LT.3) GO TO 7
  1295.       DO 6 J=1,ND
  1296.       DO 6 I=1,IT
  1297. 6     CB(I,J)=(0.,0.)
  1298. 7     I1=ISV+1
  1299.       I2=ISV+IT
  1300.       IN2=I2
  1301.       IF (IN2.GT.N1) IN2=N1
  1302.       IM1=I1-N1
  1303.       IM2=I2-N1
  1304.       IF (IM1.LT.1) IM1=1
  1305.       IMX=1
  1306.       IF (I1.LE.N1) IMX=N1-I1+2
  1307.       IF (N2.GT.N) GO TO 12
  1308. C     FILL B(WW),B(WS).  FOR ICASX=1,2 FILL D(WW),D(WS)
  1309.       DO 11 J=N2,N
  1310.       CALL TRIO (J)
  1311.       DO 9 I=1,JSNO
  1312.       JSS=JCO(I)
  1313.       IF (JSS.LT.N2) GO TO 8
  1314. C     SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT
  1315.       JCO(I)=JSS-N1
  1316.       GO TO 9
  1317. C     SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT
  1318. 8     JCO(I)=NEQS+ICONX(JSS)
  1319. 9     CONTINUE
  1320.       IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CB,NB,CB,NB,0)
  1321.       IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CB(IMX,1),NB,CB,NB,0)
  1322.       IF (ICASX.GT.2) GO TO 11
  1323.       CALL CMWW (J,N2,N,CD,ND,CD,ND,1)
  1324.       IF (M2.LE.M) CALL CMWS (J,M2EQ,MEQ,CD(1,IST),ND,CD,ND,1)
  1325. C     LOADING IN D(WW)
  1326.       IF (NLOAD.EQ.0) GO TO 11
  1327.       IR=J-N1
  1328.       EXK=ZARRAY(J)
  1329.       DO 10 I=1,JSNO
  1330.       JSS=JCO(I)
  1331. 10    CD(JSS,IR)=CD(JSS,IR)-(AX(I)+CX(I))*EXK
  1332. 11    CONTINUE
  1333. 12    IF (NSCON.EQ.0) GO TO 20
  1334. C     FILL B(WW)PRIME
  1335.       DO 19 I=1,NSCON
  1336.       J=ISCON(I)
  1337. C     SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICH
  1338. C     CONNECT TO NEW SEGMENTS
  1339.       CALL TRIO (J)
  1340.       JSS=0
  1341.       DO 15 IX=1,JSNO
  1342.       IR=JCO(IX)
  1343.       IF (IR.LT.N2) GO TO 13
  1344.       IR=IR-N1
  1345.       GO TO 14
  1346. 13    IR=ICONX(IR)
  1347.       IF (IR.EQ.0) GO TO 15
  1348.       IR=NEQS+IR
  1349. 14    JSS=JSS+1
  1350.       JCO(JSS)=IR
  1351.       AX(JSS)=AX(IX)
  1352.       BX(JSS)=BX(IX)
  1353.       CX(JSS)=CX(IX)
  1354. 15    CONTINUE
  1355.       JSNO=JSS
  1356.       IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CB,NB,CB,NB,0)
  1357.       IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CB(IMX,1),NB,CB,NB,0)
  1358. C     SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OF
  1359. C     MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEW
  1360. C     SEGMENT ON END OPPOSITE PATCH.
  1361.       IF (I1.LE.IN2) CALL CMSW (J,I,I1,IN2,CB,CB,0,NB,-1)
  1362.       IF (NLODF.EQ.0) GO TO 17
  1363.       JX=J-ISV
  1364.       IF (JX.LT.1.OR.JX.GT.IT) GO TO 17
  1365.       EXK=ZARRAY(J)
  1366.       DO 16 IX=1,JSNO
  1367.       JSS=JCO(IX)
  1368. 16    CB(JX,JSS)=CB(JX,JSS)-(AX(IX)+CX(IX))*EXK
  1369. C     SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTS
  1370. C     EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS.
  1371. 17    CALL TBF (J,1)
  1372.       JSX=JSNO
  1373.       JSNO=1
  1374.       IR=JCO(1)
  1375.       JCO(1)=NEQS+I
  1376.       DO 19 IX=1,JSX
  1377.       IF (IX.EQ.1) GO TO 18
  1378.       IR=JCO(IX)
  1379.       AX(1)=AX(IX)
  1380.       BX(1)=BX(IX)
  1381.       CX(1)=CX(IX)
  1382. 18    IF (IR.GT.N1) GO TO 19
  1383.       IF (ICONX(IR).NE.0) GO TO 19
  1384.       IF (I1.LE.IN2) CALL CMWW (IR,I1,IN2,CB,NB,CB,NB,0)
  1385.       IF (IM1.LE.IM2) CALL CMWS (IR,IM1,IM2,CB(IMX,1),NB,CB,NB,0)
  1386. C     LOADING FOR B(WW)PRIME
  1387.       IF (NLODF.EQ.0) GO TO 19
  1388.       JX=IR-ISV
  1389.       IF (JX.LT.1.OR.JX.GT.IT) GO TO 19
  1390.       EXK=ZARRAY(IR)
  1391.       JSS=JCO(1)
  1392.       CB(JX,JSS)=CB(JX,JSS)-(AX(1)+CX(1))*EXK
  1393. 19    CONTINUE
  1394. 20    IF (NPCON.EQ.0) GO TO 22
  1395.       JSS=NEQP
  1396. C     FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR
  1397. C     PATCHES THAT CONNECT TO NEW SEGMENTS
  1398.       DO 21 I=1,NPCON
  1399.       IX=IPCON(I)*2+N1-ISV
  1400.       IR=IX-1
  1401.       JSS=JSS+1
  1402.       IF (IR.GT.0.AND.IR.LE.IT) CB(IR,JSS)=(1.,0.)
  1403.       JSS=JSS+1
  1404.       IF (IX.GT.0.AND.IX.LE.IT) CB(IX,JSS)=(1.,0.)
  1405. 21    CONTINUE
  1406. 22    IF (M2.GT.M) GO TO 23
  1407. C     FILL B(SW) AND B(SS)
  1408.       IF (I1.LE.IN2) CALL CMSW (M2,M,I1,IN2,CB(1,IST),CB,N1,NB,0)
  1409.       IF (IM1.LE.IM2) CALL CMSS (M2,M,IM1,IM2,CB(IMX,IST),NB,0)
  1410. 23    IF (ICASX.EQ.1) GO TO 24
  1411.       WRITE (14) ((CB(I,J),I=1,IT),J=1,ND)
  1412. 24    CONTINUE
  1413. C     FILLING B COMPLETE.  START ON C AND D
  1414.       IT=NPBL
  1415.       ISV=-NPBL
  1416.       DO 43 IBLK=1,NBBL
  1417.       ISV=ISV+NPBL
  1418.       ISVV=ISV+NC
  1419.       IF (IBLK.EQ.NBBL) IT=NLBL
  1420.       IF (ICASX.LT.3) GO TO 27
  1421.       DO 26 J=1,IT
  1422.       DO 25 I=1,NC
  1423. 25    CC(I,J)=(0.,0.)
  1424.       DO 26 I=1,ND
  1425. 26    CD(I,J)=(0.,0.)
  1426. 27    I1=ISVV+1
  1427.       I2=ISVV+IT
  1428.       IN1=I1-M1EQ
  1429.       IN2=I2-M1EQ
  1430.       IF (IN2.GT.N) IN2=N
  1431.       IM1=I1-N
  1432.       IM2=I2-N
  1433.       IF (IM1.LT.M2EQ) IM1=M2EQ
  1434.       IF (IM2.GT.MEQ) IM2=MEQ
  1435.       IMX=1
  1436.       IF (IN1.LE.IN2) IMX=NEQN-I1+2
  1437.       IF (ICASX.LT.3) GO TO 32
  1438.       IF (N2.GT.N) GO TO 32
  1439. C     SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2
  1440.       DO 31 J=N2,N
  1441.       CALL TRIO (J)
  1442.       DO 29 I=1,JSNO
  1443.       JSS=JCO(I)
  1444.       IF (JSS.LT.N2) GO TO 28
  1445.       JCO(I)=JSS-N1
  1446.       GO TO 29
  1447. 28    JCO(I)=NEQS+ICONX(JSS)
  1448. 29    CONTINUE
  1449.       IF (IN1.LE.IN2) CALL CMWW (J,IN1,IN2,CD,ND,CD,ND,1)
  1450.       IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CD(1,IMX),ND,CD,ND,1)
  1451.       IF (NLOAD.EQ.0) GO TO 31
  1452.       IR=J-N1-ISV
  1453.       IF (IR.LT.1.OR.IR.GT.IT) GO TO 31
  1454.       EXK=ZARRAY(J)
  1455.       DO 30 I=1,JSNO
  1456.       JSS=JCO(I)
  1457. 30    CD(JSS,IR)=CD(JSS,IR)-(AX(I)+CX(I))*EXK
  1458. 31    CONTINUE
  1459. 32    IF (M2.GT.M) GO TO 33
  1460. C     FILL D(SW) AND D(SS)
  1461.       IF (IN1.LE.IN2) CALL CMSW (M2,M,IN1,IN2,CD(IST,1),CD,N1,ND,1)
  1462.       IF (IM1.LE.IM2) CALL CMSS (M2,M,IM1,IM2,CD(IST,IMX),ND,1)
  1463. 33    IF (N1.LT.1) GO TO 39
  1464. C     FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME.
  1465.       DO 37 J=1,N1
  1466.       CALL TRIO (J)
  1467.       IF (NSCON.EQ.0) GO TO 36
  1468.       DO 35 IX=1,JSNO
  1469.       JSS=JCO(IX)
  1470.       IF (JSS.LT.N2) GO TO 34
  1471.       JCO(IX)=JSS+M1EQ
  1472.       GO TO 35
  1473. 34    IR=ICONX(JSS)
  1474.       IF (IR.NE.0) JCO(IX)=NEQSP+IR
  1475. 35    CONTINUE
  1476. 36    IF (IN1.LE.IN2) CALL CMWW (J,IN1,IN2,CC,NC,CD,ND,ITX)
  1477.       IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CC(1,IMX),NC,CD(1,IMX),ND,ITX
  1478.      1)
  1479. 37    CONTINUE
  1480.       IF (NSCON.EQ.0) GO TO 39
  1481. C     FILL C(WW)PRIME
  1482.       DO 38 IX=1,NSCON
  1483.       IR=ISCON(IX)
  1484.       JSS=NEQS+IX-ISV
  1485.       IF (JSS.GT.0.AND.JSS.LE.IT) CC(IR,JSS)=(1.,0.)
  1486. 38    CONTINUE
  1487. 39    IF (NPCON.EQ.0) GO TO 41
  1488.       JSS=NEQP-ISV
  1489. C     FILL C(SS)PRIME
  1490.       DO 40 I=1,NPCON
  1491.       IX=IPCON(I)*2+N1
  1492.       IR=IX-1
  1493.       JSS=JSS+1
  1494.       IF (JSS.GT.0.AND.JSS.LE.IT) CC(IR,JSS)=(1.,0.)
  1495.       JSS=JSS+1
  1496.       IF (JSS.GT.0.AND.JSS.LE.IT) CC(IX,JSS)=(1.,0.)
  1497. 40    CONTINUE
  1498. 41    IF (M1.LT.1) GO TO 42
  1499. C     FILL C(SW) AND C(SS)
  1500.       IF (IN1.LE.IN2) CALL CMSW (1,M1,IN1,IN2,CC(N2,1),CC,0,NC,1)
  1501.       IF (IM1.LE.IM2) CALL CMSS (1,M1,IM1,IM2,CC(N2,IMX),NC,1)
  1502. 42    CONTINUE
  1503.       IF (ICASX.EQ.1) GO TO 43
  1504.       WRITE (12) ((CD(J,I),J=1,ND),I=1,IT)
  1505.       WRITE (15) ((CC(J,I),J=1,NC),I=1,IT)
  1506. 43    CONTINUE
  1507.       IF(ICASX.EQ.1)RETURN
  1508.       REWIND 12
  1509.       REWIND 14
  1510.       REWIND 15
  1511.       RETURN
  1512.       END
  1513.       SUBROUTINE CMSET (NROW,CM,RKHX,IEXKX)
  1514. C ***
  1515. C     DOUBLE PRECISION 6/4/85
  1516. C
  1517.       INCLUDE 'NEC2DPAR.INC'
  1518.       IMPLICIT REAL*8(A-H,O-Z)
  1519. C ***
  1520. C
  1521. C     CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM
  1522. C
  1523.       COMPLEX*16 CM,ZARRAY,ZAJ,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,SSX,
  1524.      &D,DETER
  1525.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1526.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1527.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1528.      &IPSYM
  1529.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  1530.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  1531.       COMMON /SMAT/ SSX(16,16)
  1532.       COMMON /SCRATM/ D(2*MAXSEG)
  1533.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  1534.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1535.      1CON(10),NPCON
  1536.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1537.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1538.       DIMENSION CM(NROW,1)
  1539.       MP2=2*MP
  1540.       NPEQ=NP+MP2
  1541.       NEQ=N+2*M
  1542.       NOP=NEQ/NPEQ
  1543.       IF (ICASE.GT.2) REWIND 11
  1544.       RKH=RKHX
  1545.       IEXK=IEXKX
  1546.       IOUT=2*NPBLK*NROW
  1547.       IT=NPBLK
  1548. C
  1549. C     CYCLE OVER MATRIX BLOCKS
  1550. C
  1551.       DO 13 IXBLK1=1,NBLOKS
  1552.       ISV=(IXBLK1-1)*NPBLK
  1553.       IF (IXBLK1.EQ.NBLOKS) IT=NLAST
  1554.       DO 1 I=1,NROW
  1555.       DO 1 J=1,IT
  1556. 1     CM(I,J)=(0.,0.)
  1557.       I1=ISV+1
  1558.       I2=ISV+IT
  1559.       IN2=I2
  1560.       IF (IN2.GT.NP) IN2=NP
  1561.       IM1=I1-NP
  1562.       IM2=I2-NP
  1563.       IF (IM1.LT.1) IM1=1
  1564.       IST=1
  1565.       IF (I1.LE.NP) IST=NP-I1+2
  1566.       IF (N.EQ.0) GO TO 5
  1567. C
  1568. C     WIRE SOURCE LOOP
  1569. C
  1570.       DO 4 J=1,N
  1571.       CALL TRIO (J)
  1572.       DO 2 I=1,JSNO
  1573.       IJ=JCO(I)
  1574. 2     JCO(I)=((IJ-1)/NP)*MP2+IJ
  1575.       IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CM,NROW,CM,NROW,1)
  1576.       IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CM(1,IST),NROW,CM,NROW,1)
  1577.       IF (NLOAD.EQ.0) GO TO 4
  1578. C
  1579. C     MATRIX ELEMENTS MODIFIED BY LOADING
  1580. C
  1581.       IF (J.GT.NP) GO TO 4
  1582.       IPR=J-ISV
  1583.       IF (IPR.LT.1.OR.IPR.GT.IT) GO TO 4
  1584.       ZAJ=ZARRAY(J)
  1585.       DO 3 I=1,JSNO
  1586.       JSS=JCO(I)
  1587. 3     CM(JSS,IPR)=CM(JSS,IPR)-(AX(I)+CX(I))*ZAJ
  1588. 4     CONTINUE
  1589. 5     IF (M.EQ.0) GO TO 7
  1590. C     MATRIX ELEMENTS FOR PATCH CURRENT SOURCES
  1591.       JM1=1-MP
  1592.       JM2=0
  1593.       JST=1-MP2
  1594.       DO 6 I=1,NOP
  1595.       JM1=JM1+MP
  1596.       JM2=JM2+MP
  1597.       JST=JST+NPEQ
  1598.       IF (I1.LE.IN2) CALL CMSW (JM1,JM2,I1,IN2,CM(JST,1),CM,0,NROW,1)
  1599.       IF (IM1.LE.IM2) CALL CMSS (JM1,JM2,IM1,IM2,CM(JST,IST),NROW,1)
  1600. 6     CONTINUE
  1601. 7     IF (ICASE.EQ.1) GO TO 13
  1602.       IF (ICASE.EQ.3) GO TO 12
  1603. C     COMBINE ELEMENTS FOR SYMMETRY MODES
  1604.       DO 11 I=1,IT
  1605.       DO 11 J=1,NPEQ
  1606.       DO 8 K=1,NOP
  1607.       KA=J+(K-1)*NPEQ
  1608. 8     D(K)=CM(KA,I)
  1609.       DETER=D(1)
  1610.       DO 9 KK=2,NOP
  1611. 9     DETER=DETER+D(KK)
  1612.       CM(J,I)=DETER
  1613.       DO 11 K=2,NOP
  1614.       KA=J+(K-1)*NPEQ
  1615.       DETER=D(1)
  1616.       DO 10 KK=2,NOP
  1617. 10    DETER=DETER+D(KK)*SSX(K,KK)
  1618.       CM(KA,I)=DETER
  1619. 11    CONTINUE
  1620.       IF (ICASE.LT.3) GO TO 13
  1621. C     WRITE BLOCK FOR OUT-OF-CORE CASES.
  1622. 12    CALL BLCKOT (CM,11,1,IOUT,1,31)
  1623. 13    CONTINUE
  1624.       IF (ICASE.GT.2) REWIND 11
  1625.       RETURN
  1626.       END
  1627.       SUBROUTINE CMSS (J1,J2,IM1,IM2,CM,NROW,ITRP)
  1628. C ***
  1629. C     DOUBLE PRECISION 6/4/85
  1630. C
  1631.       INCLUDE 'NEC2DPAR.INC'
  1632.       IMPLICIT REAL*8(A-H,O-Z)
  1633. C ***
  1634. C     CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.
  1635.       COMPLEX*16 G11,G12,G21,G22,CM,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  1636.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1637.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1638.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1639.      &IPSYM
  1640.       COMMON /ANGL/ SALP(MAXSEG)
  1641.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1642.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1643.       DIMENSION CM(NROW,1)
  1644.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1645.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  1646.      12), (T2Z,ITAG)
  1647. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  1648. C    1J,IND1), (T2ZJ,IND2)
  1649.       LDP=LD+1
  1650.       I1=(IM1+1)/2
  1651.       I2=(IM2+1)/2
  1652.       ICOMP=I1*2-3
  1653.       II1=-1
  1654.       IF (ICOMP+2.LT.IM1) II1=-2
  1655. C     LOOP OVER OBSERVATION PATCHES
  1656.       DO 5 I=I1,I2
  1657.       IL=LDP-I
  1658.       ICOMP=ICOMP+2
  1659.       II1=II1+2
  1660.       II2=II1+1
  1661.       T1XI=T1X(IL)*SALP(IL)
  1662.       T1YI=T1Y(IL)*SALP(IL)
  1663.       T1ZI=T1Z(IL)*SALP(IL)
  1664.       T2XI=T2X(IL)*SALP(IL)
  1665.       T2YI=T2Y(IL)*SALP(IL)
  1666.       T2ZI=T2Z(IL)*SALP(IL)
  1667.       XI=X(IL)
  1668.       YI=Y(IL)
  1669.       ZI=Z(IL)
  1670.       JJ1=-1
  1671. C     LOOP OVER SOURCE PATCHES
  1672.       DO 5 J=J1,J2
  1673.       JL=LDP-J
  1674.       JJ1=JJ1+2
  1675.       JJ2=JJ1+1
  1676.       S=BI(JL)
  1677.       XJ=X(JL)
  1678.       YJ=Y(JL)
  1679.       ZJ=Z(JL)
  1680.       T1XJ=T1X(JL)
  1681.       T1YJ=T1Y(JL)
  1682.       T1ZJ=T1Z(JL)
  1683.       T2XJ=T2X(JL)
  1684.       T2YJ=T2Y(JL)
  1685.       T2ZJ=T2Z(JL)
  1686.       CALL HINTG (XI,YI,ZI)
  1687.       G11=-(T2XI*EXK+T2YI*EYK+T2ZI*EZK)
  1688.       G12=-(T2XI*EXS+T2YI*EYS+T2ZI*EZS)
  1689.       G21=-(T1XI*EXK+T1YI*EYK+T1ZI*EZK)
  1690.       G22=-(T1XI*EXS+T1YI*EYS+T1ZI*EZS)
  1691.       IF (I.NE.J) GO TO 1
  1692.       G11=G11-.5
  1693.       G22=G22+.5
  1694. 1     IF (ITRP.NE.0) GO TO 3
  1695. C     NORMAL FILL
  1696.       IF (ICOMP.LT.IM1) GO TO 2
  1697.       CM(II1,JJ1)=G11
  1698.       CM(II1,JJ2)=G12
  1699. 2     IF (ICOMP.GE.IM2) GO TO 5
  1700.       CM(II2,JJ1)=G21
  1701.       CM(II2,JJ2)=G22
  1702.       GO TO 5
  1703. C     TRANSPOSED FILL
  1704. 3     IF (ICOMP.LT.IM1) GO TO 4
  1705.       CM(JJ1,II1)=G11
  1706.       CM(JJ2,II1)=G12
  1707. 4     IF (ICOMP.GE.IM2) GO TO 5
  1708.       CM(JJ1,II2)=G21
  1709.       CM(JJ2,II2)=G22
  1710. 5     CONTINUE
  1711.       RETURN
  1712.       END
  1713.       SUBROUTINE CMSW (J1,J2,I1,I2,CM,CW,NCW,NROW,ITRP)
  1714. C ***
  1715. C     DOUBLE PRECISION 6/4/85
  1716. C
  1717.       INCLUDE 'NEC2DPAR.INC'
  1718.       IMPLICIT REAL*8(A-H,O-Z)
  1719. C ***
  1720. C     COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT
  1721.       COMPLEX*16 CM,ZRATI,ZRATI2,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  1722.      1,EMEL,CW,FRATI
  1723.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1724.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1725.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1726.      &IPSYM
  1727.       COMMON /ANGL/ SALP(MAXSEG)
  1728.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  1729.      1IPERF,T1,T2
  1730.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1731.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1732.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1733.      1CON(10),NPCON
  1734.       DIMENSION CAB(1), SAB(1), CM(NROW,1), CW(NROW,1)
  1735.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), EMEL(9)
  1736.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  1737.      12), (T2Z,ITAG), (CAB,ALP), (SAB,BET)
  1738. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  1739. C    1J,IND1), (T2ZJ,IND2)
  1740.       DATA PI/3.141592654D+0/
  1741.       LDP=LD+1
  1742.       NEQS=N-N1+2*(M-M1)
  1743.       IF (ITRP.LT.0) GO TO 13
  1744.       K=0
  1745.       ICGO=1
  1746. C     OBSERVATION LOOP
  1747.       DO 12 I=I1,I2
  1748.       K=K+1
  1749.       XI=X(I)
  1750.       YI=Y(I)
  1751.       ZI=Z(I)
  1752.       CABI=CAB(I)
  1753.       SABI=SAB(I)
  1754.       SALPI=SALP(I)
  1755.       IPCH=0
  1756.       IF (ICON1(I).LT.10000) GO TO 1
  1757.       IPCH=ICON1(I)-10000
  1758.       FSIGN=-1.
  1759. 1     IF (ICON2(I).LT.10000) GO TO 2
  1760.       IPCH=ICON2(I)-10000
  1761.       FSIGN=1.
  1762. 2     JL=0
  1763. C     SOURCE LOOP
  1764.       DO 12 J=J1,J2
  1765.       JS=LDP-J
  1766.       JL=JL+2
  1767.       T1XJ=T1X(JS)
  1768.       T1YJ=T1Y(JS)
  1769.       T1ZJ=T1Z(JS)
  1770.       T2XJ=T2X(JS)
  1771.       T2YJ=T2Y(JS)
  1772.       T2ZJ=T2Z(JS)
  1773.       XJ=X(JS)
  1774.       YJ=Y(JS)
  1775.       ZJ=Z(JS)
  1776.       S=BI(JS)
  1777. C     GROUND LOOP
  1778.       DO 12 IP=1,KSYMP
  1779.       IPGND=IP
  1780.       IF (IPCH.NE.J.AND.ICGO.EQ.1) GO TO 9
  1781.       IF (IP.EQ.2) GO TO 9
  1782.       IF (ICGO.GT.1) GO TO 6
  1783.       CALL PCINT (XI,YI,ZI,CABI,SABI,SALPI,EMEL)
  1784.       PY=PI*SI(I)*FSIGN
  1785.       PX=SIN(PY)
  1786.       PY=COS(PY)
  1787.       EXC=EMEL(9)*FSIGN
  1788.       CALL TRIO (I)
  1789.       IF (I.GT.N1) GO TO 3
  1790.       IL=NEQS+ICONX(I)
  1791.       GO TO 4
  1792. 3     IL=I-NCW
  1793.       IF (I.LE.NP) IL=((IL-1)/NP)*2*MP+IL
  1794. 4     IF (ITRP.NE.0) GO TO 5
  1795.       CW(K,IL)=CW(K,IL)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY)
  1796.       GO TO 6
  1797. 5     CW(IL,K)=CW(IL,K)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY)
  1798. 6     IF (ITRP.NE.0) GO TO 7
  1799.       CM(K,JL-1)=EMEL(ICGO)
  1800.       CM(K,JL)=EMEL(ICGO+4)
  1801.       GO TO 8
  1802. 7     CM(JL-1,K)=EMEL(ICGO)
  1803.       CM(JL,K)=EMEL(ICGO+4)
  1804. 8     ICGO=ICGO+1
  1805.       IF (ICGO.EQ.5) ICGO=1
  1806.       GO TO 11
  1807. 9     CALL UNERE (XI,YI,ZI)
  1808.       IF (ITRP.NE.0) GO TO 10
  1809. C     NORMAL FILL
  1810.       CM(K,JL-1)=CM(K,JL-1)+EXK*CABI+EYK*SABI+EZK*SALPI
  1811.       CM(K,JL)=CM(K,JL)+EXS*CABI+EYS*SABI+EZS*SALPI
  1812.       GO TO 11
  1813. C     TRANSPOSED FILL
  1814. 10    CM(JL-1,K)=CM(JL-1,K)+EXK*CABI+EYK*SABI+EZK*SALPI
  1815.       CM(JL,K)=CM(JL,K)+EXS*CABI+EYS*SABI+EZS*SALPI
  1816. 11    CONTINUE
  1817. 12    CONTINUE
  1818.       RETURN
  1819. C     FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON
  1820. C     OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY
  1821. 13    IF (J1.LT.I1.OR.J1.GT.I2) GO TO 16
  1822.       IPCH=ICON1(J1)
  1823.       IF (IPCH.LT.10000) GO TO 14
  1824.       IPCH=IPCH-10000
  1825.       FSIGN=-1.
  1826.       GO TO 15
  1827. 14    IPCH=ICON2(J1)
  1828.       IF (IPCH.LT.10000) GO TO 16
  1829.       IPCH=IPCH-10000
  1830.       FSIGN=1.
  1831. 15    IF (IPCH.GT.M1) GO TO 16
  1832.       JS=LDP-IPCH
  1833.       IPGND=1
  1834.       T1XJ=T1X(JS)
  1835.       T1YJ=T1Y(JS)
  1836.       T1ZJ=T1Z(JS)
  1837.       T2XJ=T2X(JS)
  1838.       T2YJ=T2Y(JS)
  1839.       T2ZJ=T2Z(JS)
  1840.       XJ=X(JS)
  1841.       YJ=Y(JS)
  1842.       ZJ=Z(JS)
  1843.       S=BI(JS)
  1844.       XI=X(J1)
  1845.       YI=Y(J1)
  1846.       ZI=Z(J1)
  1847.       CABI=CAB(J1)
  1848.       SABI=SAB(J1)
  1849.       SALPI=SALP(J1)
  1850.       CALL PCINT (XI,YI,ZI,CABI,SABI,SALPI,EMEL)
  1851.       PY=PI*SI(J1)*FSIGN
  1852.       PX=SIN(PY)
  1853.       PY=COS(PY)
  1854.       EXC=EMEL(9)*FSIGN
  1855.       IL=JCO(JSNO)
  1856.       K=J1-I1+1
  1857.       CW(K,IL)=CW(K,IL)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY)
  1858. 16    RETURN
  1859.       END
  1860.       SUBROUTINE CMWS (J,I1,I2,CM,NR,CW,NW,ITRP)
  1861. C ***
  1862. C     DOUBLE PRECISION 6/4/85
  1863. C
  1864.       INCLUDE 'NEC2DPAR.INC'
  1865.       IMPLICIT REAL*8(A-H,O-Z)
  1866. C ***
  1867. C
  1868. C     CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS
  1869. C
  1870.       COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  1871.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1872.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1873.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1874.      &IPSYM
  1875.       COMMON /ANGL/ SALP(MAXSEG)
  1876.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1877.      1CON(10),NPCON
  1878.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1879.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1880.       DIMENSION CM(NR,1), CW(NW,1), CAB(1), SAB(1)
  1881.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1882.       EQUIVALENCE (CAB,ALP), (SAB,BET), (T1X,SI), (T1Y,ALP), (T1Z,BET)
  1883.       EQUIVALENCE (T2X,ICON1), (T2Y,ICON2), (T2Z,ITAG)
  1884.       LDP=LD+1
  1885.       S=SI(J)
  1886.       B=BI(J)
  1887.       XJ=X(J)
  1888.       YJ=Y(J)
  1889.       ZJ=Z(J)
  1890.       CABJ=CAB(J)
  1891.       SABJ=SAB(J)
  1892.       SALPJ=SALP(J)
  1893. C
  1894. C     OBSERVATION LOOP
  1895. C
  1896.       IPR=0
  1897.       DO 9 I=I1,I2
  1898.       IPR=IPR+1
  1899.       IPATCH=(I+1)/2
  1900.       IK=I-(I/2)*2
  1901.       IF (IK.EQ.0.AND.IPR.NE.1) GO TO 1
  1902.       JS=LDP-IPATCH
  1903.       XI=X(JS)
  1904.       YI=Y(JS)
  1905.       ZI=Z(JS)
  1906.       CALL HSFLD (XI,YI,ZI,0.)
  1907.       IF (IK.EQ.0) GO TO 1
  1908.       TX=T2X(JS)
  1909.       TY=T2Y(JS)
  1910.       TZ=T2Z(JS)
  1911.       GO TO 2
  1912. 1     TX=T1X(JS)
  1913.       TY=T1Y(JS)
  1914.       TZ=T1Z(JS)
  1915. 2     ETK=-(EXK*TX+EYK*TY+EZK*TZ)*SALP(JS)
  1916.       ETS=-(EXS*TX+EYS*TY+EZS*TZ)*SALP(JS)
  1917.       ETC=-(EXC*TX+EYC*TY+EZC*TZ)*SALP(JS)
  1918. C
  1919. C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION
  1920. C     DATA.
  1921. C
  1922.       IF (ITRP.NE.0) GO TO 4
  1923. C     NORMAL FILL
  1924.       DO 3 IJ=1,JSNO
  1925.       JX=JCO(IJ)
  1926. 3     CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  1927.       GO TO 9
  1928. 4     IF (ITRP.EQ.2) GO TO 6
  1929. C     TRANSPOSED FILL
  1930.       DO 5 IJ=1,JSNO
  1931.       JX=JCO(IJ)
  1932. 5     CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  1933.       GO TO 9
  1934. C     TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW)
  1935. 6     DO 8 IJ=1,JSNO
  1936.       JX=JCO(IJ)
  1937.       IF (JX.GT.NR) GO TO 7
  1938.       CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  1939.       GO TO 8
  1940. 7     JX=JX-NR
  1941.       CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  1942. 8     CONTINUE
  1943. 9     CONTINUE
  1944.       RETURN
  1945.       END
  1946.       SUBROUTINE CMWW (J,I1,I2,CM,NR,CW,NW,ITRP)
  1947. C ***
  1948. C     DOUBLE PRECISION 6/4/85
  1949. C
  1950.       INCLUDE 'NEC2DPAR.INC'
  1951.       IMPLICIT REAL*8(A-H,O-Z)
  1952. C ***
  1953. C
  1954. C     CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS
  1955. C
  1956.       COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  1957.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  1958.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  1959.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  1960.      &IPSYM
  1961.       COMMON /ANGL/ SALP(MAXSEG)
  1962.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  1963.      1CON(10),NPCON
  1964.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  1965.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  1966.       DIMENSION CM(NR,1), CW(NW,1), CAB(1), SAB(1)
  1967.       EQUIVALENCE (CAB,ALP), (SAB,BET)
  1968. C     SET SOURCE SEGMENT PARAMETERS
  1969.       S=SI(J)
  1970.       B=BI(J)
  1971.       XJ=X(J)
  1972.       YJ=Y(J)
  1973.       ZJ=Z(J)
  1974.       CABJ=CAB(J)
  1975.       SABJ=SAB(J)
  1976.       SALPJ=SALP(J)
  1977.       IF (IEXK.EQ.0) GO TO 16
  1978. C     DECIDE WETHER EXT. T.W. APPROX. CAN BE USED
  1979.       IPR=ICON1(J)
  1980.       IF (IPR) 1,6,2
  1981. 1     IPR=-IPR
  1982.       IF (-ICON1(IPR).NE.J) GO TO 7
  1983.       GO TO 4
  1984. 2     IF (IPR.NE.J) GO TO 3
  1985.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7
  1986.       GO TO 5
  1987. 3     IF (ICON2(IPR).NE.J) GO TO 7
  1988. 4     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  1989.       IF (XI.LT.0.999999D+0) GO TO 7
  1990.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 7
  1991. 5     IND1=0
  1992.       GO TO 8
  1993. 6     IND1=1
  1994.       GO TO 8
  1995. 7     IND1=2
  1996. 8     IPR=ICON2(J)
  1997.       IF (IPR) 9,14,10
  1998. 9     IPR=-IPR
  1999.       IF (-ICON2(IPR).NE.J) GO TO 15
  2000.       GO TO 12
  2001. 10    IF (IPR.NE.J) GO TO 11
  2002.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15
  2003.       GO TO 13
  2004. 11    IF (ICON1(IPR).NE.J) GO TO 15
  2005. 12    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  2006.       IF (XI.LT.0.999999D+0) GO TO 15
  2007.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 15
  2008. 13    IND2=0
  2009.       GO TO 16
  2010. 14    IND2=1
  2011.       GO TO 16
  2012. 15    IND2=2
  2013. 16    CONTINUE
  2014. C
  2015. C     OBSERVATION LOOP
  2016. C
  2017.       IPR=0
  2018.       DO 23 I=I1,I2
  2019.       IPR=IPR+1
  2020.       IJ=I-J
  2021.       XI=X(I)
  2022.       YI=Y(I)
  2023.       ZI=Z(I)
  2024.       AI=BI(I)
  2025.       CABI=CAB(I)
  2026.       SABI=SAB(I)
  2027.       SALPI=SALP(I)
  2028.       CALL EFLD (XI,YI,ZI,AI,IJ)
  2029.       ETK=EXK*CABI+EYK*SABI+EZK*SALPI
  2030.       ETS=EXS*CABI+EYS*SABI+EZS*SALPI
  2031.       ETC=EXC*CABI+EYC*SABI+EZC*SALPI
  2032. C
  2033. C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION
  2034. C     DATA.
  2035. C
  2036.       IF (ITRP.NE.0) GO TO 18
  2037. C     NORMAL FILL
  2038.       DO 17 IJ=1,JSNO
  2039.       JX=JCO(IJ)
  2040. 17    CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  2041.       GO TO 23
  2042. 18    IF (ITRP.EQ.2) GO TO 20
  2043. C     TRANSPOSED FILL
  2044.       DO 19 IJ=1,JSNO
  2045.       JX=JCO(IJ)
  2046. 19    CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  2047.       GO TO 23
  2048. C     TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME.  (=CW)
  2049. 20    DO 22 IJ=1,JSNO
  2050.       JX=JCO(IJ)
  2051.       IF (JX.GT.NR) GO TO 21
  2052.       CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  2053.       GO TO 22
  2054. 21    JX=JX-NR
  2055.       CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)
  2056. 22    CONTINUE
  2057. 23    CONTINUE
  2058.       RETURN
  2059.       END
  2060.       SUBROUTINE CONECT (IGND)
  2061. C ***
  2062. C     DOUBLE PRECISION 6/4/85
  2063. C
  2064.       INCLUDE 'NEC2DPAR.INC'
  2065.       IMPLICIT REAL*8(A-H,O-Z)
  2066. C ***
  2067. C
  2068. C     CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
  2069. C     BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.
  2070. C
  2071.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  2072.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  2073.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  2074.      &IPSYM
  2075.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  2076.      1CON(10),NPCON
  2077.       DIMENSION X2(1), Y2(1), Z2(1)
  2078.       EQUIVALENCE (X2,SI), (Y2,ALP), (Z2,BET)
  2079.       DATA JMAX/30/,SMIN/1.D-3/,NSMAX/50/,NPMAX/10/
  2080.       NSCON=0
  2081.       NPCON=0
  2082.       IF (IGND.EQ.0) GO TO 3
  2083.       WRITE(3,54)
  2084.       IF (IGND.GT.0) WRITE(3,55)
  2085.       IF (IPSYM.NE.2) GO TO 1
  2086.       NP=2*NP
  2087.       MP=2*MP
  2088. 1     IF (IABS(IPSYM).LE.2) GO TO 2
  2089.       NP=N
  2090.       MP=M
  2091. 2     IF (NP.GT.N) STOP
  2092.       IF (NP.EQ.N.AND.MP.EQ.M) IPSYM=0
  2093. 3     IF (N.EQ.0) GO TO 26
  2094.       DO 15 I=1,N
  2095.       ICONX(I)=0
  2096.       XI1=X(I)
  2097.       YI1=Y(I)
  2098.       ZI1=Z(I)
  2099.       XI2=X2(I)
  2100.       YI2=Y2(I)
  2101.       ZI2=Z2(I)
  2102.       SLEN=SQRT((XI2-XI1)**2+(YI2-YI1)**2+(ZI2-ZI1)**2)*SMIN
  2103. C
  2104. C     DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.
  2105. C
  2106.       IF (IGND.LT.1) GO TO 5
  2107.       IF (ZI1.GT.-SLEN) GO TO 4
  2108.       WRITE(3,56)  I
  2109.       STOP
  2110. 4     IF (ZI1.GT.SLEN) GO TO 5
  2111.       ICON1(I)=I
  2112.       Z(I)=0.
  2113.       GO TO 9
  2114. 5     IC=I
  2115.       DO 7 J=2,N
  2116.       IC=IC+1
  2117.       IF (IC.GT.N) IC=1
  2118.       SEP=ABS(XI1-X(IC))+ABS(YI1-Y(IC))+ABS(ZI1-Z(IC))
  2119.       IF (SEP.GT.SLEN) GO TO 6
  2120.       ICON1(I)=-IC
  2121.       GO TO 8
  2122. 6     SEP=ABS(XI1-X2(IC))+ABS(YI1-Y2(IC))+ABS(ZI1-Z2(IC))
  2123.       IF (SEP.GT.SLEN) GO TO 7
  2124.       ICON1(I)=IC
  2125.       GO TO 8
  2126. 7     CONTINUE
  2127.       IF (I.LT.N2.AND.ICON1(I).GT.10000) GO TO 8
  2128.       ICON1(I)=0
  2129. C
  2130. C     DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.
  2131. C
  2132. 8     IF (IGND.LT.1) GO TO 12
  2133. 9     IF (ZI2.GT.-SLEN) GO TO 10
  2134.       WRITE(3,56)  I
  2135.       STOP
  2136. 10    IF (ZI2.GT.SLEN) GO TO 12
  2137.       IF (ICON1(I).NE.I) GO TO 11
  2138.       WRITE(3,57)  I
  2139.       STOP
  2140. 11    ICON2(I)=I
  2141.       Z2(I)=0.
  2142.       GO TO 15
  2143. 12    IC=I
  2144.       DO 14 J=2,N
  2145.       IC=IC+1
  2146.       IF (IC.GT.N) IC=1
  2147.       SEP=ABS(XI2-X(IC))+ABS(YI2-Y(IC))+ABS(ZI2-Z(IC))
  2148.       IF (SEP.GT.SLEN) GO TO 13
  2149.       ICON2(I)=IC
  2150.       GO TO 15
  2151. 13    SEP=ABS(XI2-X2(IC))+ABS(YI2-Y2(IC))+ABS(ZI2-Z2(IC))
  2152.       IF (SEP.GT.SLEN) GO TO 14
  2153.       ICON2(I)=-IC
  2154.       GO TO 15
  2155. 14    CONTINUE
  2156.       IF (I.LT.N2.AND.ICON2(I).GT.10000) GO TO 15
  2157.       ICON2(I)=0
  2158. 15    CONTINUE
  2159.       IF (M.EQ.0) GO TO 26
  2160. C     FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES
  2161.       IX=LD+1-M1
  2162.       I=M2
  2163. 16    IF (I.GT.M) GO TO 20
  2164.       IX=IX-1
  2165.       XS=X(IX)
  2166.       YS=Y(IX)
  2167.       ZS=Z(IX)
  2168.       DO 18 ISEG=1,N
  2169.       XI1=X(ISEG)
  2170.       YI1=Y(ISEG)
  2171.       ZI1=Z(ISEG)
  2172.       XI2=X2(ISEG)
  2173.       YI2=Y2(ISEG)
  2174.       ZI2=Z2(ISEG)
  2175.       SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN
  2176. C     FOR FIRST END OF SEGMENT
  2177.       SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS)
  2178.       IF (SEP.GT.SLEN) GO TO 17
  2179. C     CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.
  2180.       ICON1(ISEG)=10000+I
  2181.       IC=0
  2182.       CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)
  2183.       GO TO 19
  2184. 17    SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)
  2185.       IF (SEP.GT.SLEN) GO TO 18
  2186.       ICON2(ISEG)=10000+I
  2187.       IC=0
  2188.       CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)
  2189.       GO TO 19
  2190. 18    CONTINUE
  2191. 19    I=I+1
  2192.       GO TO 16
  2193. C     REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.
  2194. 20    IF (M1.EQ.0.OR.N2.GT.N) GO TO 26
  2195.       IX=LD+1
  2196.       I=1
  2197. 21    IF (I.GT.M1) GO TO 25
  2198.       IX=IX-1
  2199.       XS=X(IX)
  2200.       YS=Y(IX)
  2201.       ZS=Z(IX)
  2202.       DO 23 ISEG=N2,N
  2203.       XI1=X(ISEG)
  2204.       YI1=Y(ISEG)
  2205.       ZI1=Z(ISEG)
  2206.       XI2=X2(ISEG)
  2207.       YI2=Y2(ISEG)
  2208.       ZI2=Z2(ISEG)
  2209.       SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN
  2210.       SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS)
  2211.       IF (SEP.GT.SLEN) GO TO 22
  2212.       ICON1(ISEG)=10001+M
  2213.       IC=1
  2214.       NPCON=NPCON+1
  2215.       IPCON(NPCON)=I
  2216.       CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)
  2217.       GO TO 24
  2218. 22    SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)
  2219.       IF (SEP.GT.SLEN) GO TO 23
  2220.       ICON2(ISEG)=10001+M
  2221.       IC=1
  2222.       NPCON=NPCON+1
  2223.       IPCON(NPCON)=I
  2224.       CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)
  2225.       GO TO 24
  2226. 23    CONTINUE
  2227. 24    I=I+1
  2228.       GO TO 21
  2229. 25    IF (NPCON.LE.NPMAX) GO TO 26
  2230.       WRITE(3,62)  NPMAX
  2231.       STOP
  2232. 26    WRITE(3,58)  N,NP,IPSYM
  2233.       IF (M.GT.0) WRITE(3,61)  M,MP
  2234.       ISEG=(N+M)/(NP+MP)
  2235.       IF (ISEG.EQ.1) GO TO 30
  2236.       IF (IPSYM) 28,27,29
  2237. 27    STOP
  2238. 28    WRITE(3,59) ISEG
  2239.       GO TO 30
  2240. 29    IC=ISEG/2
  2241.       IF (ISEG.EQ.8) IC=3
  2242.       WRITE(3,60)  IC
  2243. 30    IF (N.EQ.0) GO TO 48
  2244.       WRITE(3,50)
  2245.       ISEG=0
  2246. C     ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE.  PRINT JUNCTIONS
  2247. C     OF 3 OR MORE SEG.  ALSO FIND OLD SEG. CONNECTING TO NEW SEG.
  2248.       DO 44 J=1,N
  2249.       IEND=-1
  2250.       JEND=-1
  2251.       IX=ICON1(J)
  2252.       IC=1
  2253.       JCO(1)=-J
  2254.       XA=X(J)
  2255.       YA=Y(J)
  2256.       ZA=Z(J)
  2257. 31    IF (IX.EQ.0) GO TO 43
  2258.       IF (IX.EQ.J) GO TO 43
  2259.       IF (IX.GT.10000) GO TO 43
  2260.       NSFLG=0
  2261. 32    IF (IX) 33,49,34
  2262. 33    IX=-IX
  2263.       GO TO 35
  2264. 34    JEND=-JEND
  2265. 35    IF (IX.EQ.J) GO TO 37
  2266.       IF (IX.LT.J) GO TO 43
  2267.       IC=IC+1
  2268.       IF (IC.GT.JMAX) GO TO 49
  2269.       JCO(IC)=IX*JEND
  2270.       IF (IX.GT.N1) NSFLG=1
  2271.       IF (JEND.EQ.1) GO TO 36
  2272.       XA=XA+X(IX)
  2273.       YA=YA+Y(IX)
  2274.       ZA=ZA+Z(IX)
  2275.       IX=ICON1(IX)
  2276.       GO TO 32
  2277. 36    XA=XA+X2(IX)
  2278.       YA=YA+Y2(IX)
  2279.       ZA=ZA+Z2(IX)
  2280.       IX=ICON2(IX)
  2281.       GO TO 32
  2282. 37    SEP=IC
  2283.       XA=XA/SEP
  2284.       YA=YA/SEP
  2285.       ZA=ZA/SEP
  2286.       DO 39 I=1,IC
  2287.       IX=JCO(I)
  2288.       IF (IX.GT.0) GO TO 38
  2289.       IX=-IX
  2290.       X(IX)=XA
  2291.       Y(IX)=YA
  2292.       Z(IX)=ZA
  2293.       GO TO 39
  2294. 38    X2(IX)=XA
  2295.       Y2(IX)=YA
  2296.       Z2(IX)=ZA
  2297. 39    CONTINUE
  2298.       IF (N1.EQ.0) GO TO 42
  2299.       IF (NSFLG.EQ.0) GO TO 42
  2300.       DO 41 I=1,IC
  2301.       IX=IABS(JCO(I))
  2302.       IF (IX.GT.N1) GO TO 41
  2303.       IF (ICONX(IX).NE.0) GO TO 41
  2304.       NSCON=NSCON+1
  2305.       IF (NSCON.LE.NSMAX) GO TO 40
  2306.       WRITE(3,62)  NSMAX
  2307.       STOP
  2308. 40    ISCON(NSCON)=IX
  2309.       ICONX(IX)=NSCON
  2310. 41    CONTINUE
  2311. 42    IF (IC.LT.3) GO TO 43
  2312.       ISEG=ISEG+1
  2313.       WRITE(3,51) ISEG,(JCO(I),I=1,IC)
  2314. 43    IF (IEND.EQ.1) GO TO 44
  2315.       IEND=1
  2316.       JEND=1
  2317.       IX=ICON2(J)
  2318.       IC=1
  2319.       JCO(1)=J
  2320.       XA=X2(J)
  2321.       YA=Y2(J)
  2322.       ZA=Z2(J)
  2323.       GO TO 31
  2324. 44    CONTINUE
  2325.       IF (ISEG.EQ.0) WRITE(3,52)
  2326.       IF (N1.EQ.0.OR.M1.EQ.M) GO TO 48
  2327. C     FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES
  2328.       DO 47 J=1,N1
  2329.       IX=ICON1(J)
  2330.       IF (IX.LT.10000) GO TO 45
  2331.       IX=IX-10000
  2332.       IF (IX.GT.M1) GO TO 46
  2333. 45    IX=ICON2(J)
  2334.       IF (IX.LT.10000) GO TO 47
  2335.       IX=IX-10000
  2336.       IF (IX.LT.M2) GO TO 47
  2337. 46    IF (ICONX(J).NE.0) GO TO 47
  2338.       NSCON=NSCON+1
  2339.       ISCON(NSCON)=J
  2340.       ICONX(J)=NSCON
  2341. 47    CONTINUE
  2342. 48    CONTINUE
  2343.       RETURN
  2344. 49    WRITE(3,53)  IX
  2345.       STOP
  2346. C
  2347. 50    FORMAT (//,9X,27H- MULTIPLE WIRE JUNCTIONS -,/,1X,8HJUNCTION,4X,36
  2348.      1HSEGMENTS  (- FOR END 1, + FOR END 2))
  2349. 51    FORMAT (1X,I5,5X,20I5,/,(11X,20I5))
  2350. 52    FORMAT (2X,4HNONE)
  2351. 53    FORMAT (47H CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
  2352. 54    FORMAT (/,3X,23HGROUND PLANE SPECIFIED.)
  2353. 55    FORMAT (/,3X,46HWHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ,38H
  2354.      1INTERPOLATED TO IMAGE IN GROUND PLANE.,/)
  2355. 56    FORMAT (30H GEOMETRY DATA ERROR-- SEGMENT,I5,21H EXTENDS BELOW GRO
  2356.      1UND)
  2357. 57    FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,16H LIES IN GROUND ,6H
  2358.      1PLANE.)
  2359. 58    FORMAT (/,3X,20HTOTAL SEGMENTS USED=,I5,5X,12HNO. SEG. IN ,17HA SY
  2360.      1MMETRIC CELL=,I5,5X,14HSYMMETRY FLAG=,I3)
  2361. 59    FORMAT (14H STRUCTURE HAS,I4,25H FOLD ROTATIONAL SYMMETRY,/)
  2362. 60    FORMAT (14H STRUCTURE HAS,I2,19H PLANES OF SYMMETRY,/)
  2363. 61    FORMAT (3X,19HTOTAL PATCHES USED=,I5,6X,32HNO. PATCHES IN A SYMMET
  2364.      1RIC CELL=,I5)
  2365. 62    FORMAT ( 82H ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS
  2366.      1OR PATCHES EXCEEDS LIMIT OF,I5)
  2367.       END
  2368.       SUBROUTINE COUPLE (CUR,WLAM)
  2369. C ***
  2370. C     DOUBLE PRECISION 6/4/85
  2371. C
  2372.       IMPLICIT REAL*8(A-H,O-Z)
  2373. C ***
  2374. C
  2375. C     COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.
  2376. C
  2377.       COMPLEX*16 Y11A,Y12A,CUR,Y11,Y12,Y22,YL,YIN,ZL,ZIN,RHO,VQD,VSANT
  2378.      1,VQDS
  2379.       COMMON /YPARM/ NCOUP,ICOUP,NCTAG(5),NCSEG(5),Y11A(5),Y12A(20)
  2380.       COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
  2381.      130),NVQD,NSANT,NQDS
  2382.       DIMENSION CUR(1)
  2383.       IF (NSANT.NE.1.OR.NVQD.NE.0) RETURN
  2384.       J=ISEGNO(NCTAG(ICOUP+1),NCSEG(ICOUP+1))
  2385.       IF (J.NE.ISANT(1)) RETURN
  2386.       ICOUP=ICOUP+1
  2387.       ZIN=VSANT(1)
  2388.       Y11A(ICOUP)=CUR(J)*WLAM/ZIN
  2389.       L1=(ICOUP-1)*(NCOUP-1)
  2390.       DO 1 I=1,NCOUP
  2391.       IF (I.EQ.ICOUP) GO TO 1
  2392.       K=ISEGNO(NCTAG(I),NCSEG(I))
  2393.       L1=L1+1
  2394.       Y12A(L1)=CUR(K)*WLAM/ZIN
  2395. 1     CONTINUE
  2396.       IF (ICOUP.LT.NCOUP) RETURN
  2397.       WRITE(3,6)
  2398.       NPM1=NCOUP-1
  2399.       DO 5 I=1,NPM1
  2400.       ITT1=NCTAG(I)
  2401.       ITS1=NCSEG(I)
  2402.       ISG1=ISEGNO(ITT1,ITS1)
  2403.       L1=I+1
  2404.       DO 5 J=L1,NCOUP
  2405.       ITT2=NCTAG(J)
  2406.       ITS2=NCSEG(J)
  2407.       ISG2=ISEGNO(ITT2,ITS2)
  2408.       J1=J+(I-1)*NPM1-1
  2409.       J2=I+(J-1)*NPM1
  2410.       Y11=Y11A(I)
  2411.       Y22=Y11A(J)
  2412.       Y12=.5*(Y12A(J1)+Y12A(J2))
  2413.       YIN=Y12*Y12
  2414.       DBC=ABS(YIN)
  2415.       C=DBC/(2.*DREAL(Y11)*DREAL(Y22)-DREAL(YIN))
  2416.       IF (C.LT.0..OR.C.GT.1.) GO TO 4
  2417.       IF (C.LT..01) GO TO 2
  2418.       GMAX=(1.-SQRT(1.-C*C))/C
  2419.       GO TO 3
  2420. 2     GMAX=.5*(C+.25*C*C*C)
  2421. 3     RHO=GMAX*DCONJG(YIN)/DBC
  2422.       YL=((1.-RHO)/(1.+RHO)+1.)*DREAL(Y22)-Y22
  2423.       ZL=1./YL
  2424.       YIN=Y11-YIN/(Y22+YL)
  2425.       ZIN=1./YIN
  2426.       DBC=DB10(GMAX)
  2427.       WRITE(3,7)  ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,DBC,ZL,ZIN
  2428.       GO TO 5
  2429. 4     WRITE(3,8)  ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,C
  2430. 5     CONTINUE
  2431.       RETURN
  2432. C
  2433. 6     FORMAT (///,36X,26H- - - ISOLATION DATA - - -,//,6X,24H- - COUPLIN
  2434.      1G BETWEEN - -,8X,7HMAXIMUM,15X,32H- - - FOR MAXIMUM COUPLING - - -
  2435.      2,/,12X,4HSEG.,14X,4HSEG.,3X,8HCOUPLING,4X,25HLOAD IMPEDANCE (2ND S
  2436.      3EG.),7X,15HINPUT IMPEDANCE,/,2X,8HTAG/SEG.,3X,3HNO.,4X,8HTAG/SEG.,
  2437.      43X,3HNO.,6X,4H(DB),8X,4HREAL,9X,5HIMAG.,9X,4HREAL,9X,5HIMAG.)
  2438. 7     FORMAT (2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5))
  2439. 8     FORMAT (2(1X,I4,1X,I4,1X,I5,2X),45H**ERROR** COUPLING IS NOT BETWE
  2440.      1EN 0 AND 1. (=,1P,E12.5,1H))
  2441.       END
  2442.       SUBROUTINE DATAGN
  2443. C ***
  2444. C     DOUBLE PRECISION 6/4/85
  2445. C
  2446.       INCLUDE 'NEC2DPAR.INC'
  2447.       IMPLICIT REAL*8(A-H,O-Z)
  2448. C ***
  2449. C
  2450. C     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.
  2451. C
  2452. C***
  2453.       CHARACTER*2 GM,ATST
  2454. C***
  2455.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  2456.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  2457.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  2458.      &IPSYM
  2459.       COMMON /ANGL/ SALP(MAXSEG)
  2460. C***
  2461.       COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  2462. C***
  2463.       DIMENSION X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y
  2464.      1(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1), IPT
  2465.      2(4)
  2466.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  2467.      12), (T2Z,ITAG), (X2,SI), (Y2,ALP), (Z2,BET), (CAB,ALP), (SAB,BET)
  2468. C***
  2469.       DATA ATST/'GW','GX','GR','GS','GE','GM','SP','SM','GF','GA','SC',
  2470.      1'GC','GH'/
  2471. C***
  2472.       DATA IFX/1H ,1HX/,IFY/1H ,1HY/,IFZ/1H ,1HZ/
  2473.       DATA TA/0.01745329252D+0/,TD/57.29577951D+0/,IPT/1HP,1HR,1HT,1HQ/
  2474.       IPSYM=0
  2475.       NWIRE=0
  2476.       N=0
  2477.       NP=0
  2478.       M=0
  2479.       MP=0
  2480.       N1=0
  2481.       N2=1
  2482.       M1=0
  2483.       M2=1
  2484.       ISCT=0
  2485.       IPHD=0
  2486. C
  2487. C     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION
  2488. C     REQUESTED
  2489. C
  2490. 1     CALL READGM(2,GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD)
  2491.       IF (N+M.GT.LD) GO TO 37
  2492.       IF (GM.EQ.ATST(9)) GO TO 27
  2493.       IF (IPHD.EQ.1) GO TO 2
  2494.       WRITE(3,40)
  2495.       WRITE(3,41)
  2496.       IPHD=1
  2497. 2     IF (GM.EQ.ATST(11)) GO TO 10
  2498.       ISCT=0
  2499.       IF (GM.EQ.ATST(1)) GO TO 3
  2500.       IF (GM.EQ.ATST(2)) GO TO 18
  2501.       IF (GM.EQ.ATST(3)) GO TO 19
  2502.       IF (GM.EQ.ATST(4)) GO TO 21
  2503.       IF (GM.EQ.ATST(7)) GO TO 9
  2504.       IF (GM.EQ.ATST(8)) GO TO 13
  2505.       IF (GM.EQ.ATST(5)) GO TO 29
  2506.       IF (GM.EQ.ATST(6)) GO TO 26
  2507.       IF (GM.EQ.ATST(10)) GO TO 8
  2508. C***
  2509.       IF (GM.EQ.ATST(13)) GO TO 123
  2510. C***
  2511.       GO TO 36
  2512. C
  2513. C     GENERATE SEGMENT DATA FOR STRAIGHT WIRE.
  2514. C
  2515. 3     NWIRE=NWIRE+1
  2516.       I1=N+1
  2517.       I2=N+NS
  2518.       WRITE(3,43)  NWIRE,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG
  2519.       IF (RAD.EQ.0) GO TO 4
  2520.       XS1=1.
  2521.       YS1=1.
  2522.       GO TO 7
  2523. 4     CALL READGM(2,GM,IX,IY,XS1,YS1,ZS1,DUMMY,DUMMY,DUMMY,DUMMY)
  2524. C***
  2525.       IF (GM.EQ.ATST(12)) GO TO 6
  2526. 5     WRITE(3,48)
  2527.       STOP
  2528. 6     WRITE(3,61)  XS1,YS1,ZS1
  2529.       IF (YS1.EQ.0.OR.ZS1.EQ.0) GO TO 5
  2530.       RAD=YS1
  2531.       YS1=(ZS1/YS1)**(1./(NS-1.))
  2532. 7     CALL WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,XS1,YS1,NS,ITG)
  2533.       GO TO 1
  2534. C
  2535. C     GENERATE SEGMENT DATA FOR WIRE ARC
  2536. C
  2537. 8     NWIRE=NWIRE+1
  2538.       I1=N+1
  2539.       I2=N+NS
  2540.       WRITE(3,38)  NWIRE,XW1,YW1,ZW1,XW2,NS,I1,I2,ITG
  2541.       CALL ARC (ITG,NS,XW1,YW1,ZW1,XW2)
  2542.       GO TO 1
  2543. C***
  2544. C
  2545. C     GENERATE HELIX
  2546. C
  2547. 123   NWIRE=NWIRE+1
  2548.       I1=N+1
  2549.       I2=N+NS
  2550.       WRITE(3,124) XW1,YW1,NWIRE,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG
  2551.       CALL HELIX(XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,ITG)
  2552.       GO TO 1
  2553. C
  2554. 124   FORMAT(5X,'HELIX STRUCTURE-   AXIAL SPACING BETWEEN TURNS =',F8.3,
  2555.      1' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X,
  2556.      2F8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)
  2557. C***
  2558. C
  2559. C     GENERATE SINGLE NEW PATCH
  2560. C
  2561. 9     I1=M+1
  2562.       NS=NS+1
  2563.       IF (ITG.NE.0) GO TO 17
  2564.       WRITE(3,51)  I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2
  2565.       IF (NS.EQ.2.OR.NS.EQ.4) ISCT=1
  2566.       IF (NS.GT.1) GO TO 14
  2567.       XW2=XW2*TA
  2568.       YW2=YW2*TA
  2569.       GO TO 16
  2570. 10    IF (ISCT.EQ.0) GO TO 17
  2571.       I1=M+1
  2572.       NS=NS+1
  2573.       IF (ITG.NE.0) GO TO 17
  2574.       IF (NS.NE.2.AND.NS.NE.4) GO TO 17
  2575.       XS1=X4
  2576.       YS1=Y4
  2577.       ZS1=Z4
  2578.       XS2=X3
  2579.       YS2=Y3
  2580.       ZS2=Z3
  2581.       X3=XW1
  2582.       Y3=YW1
  2583.       Z3=ZW1
  2584.       IF (NS.NE.4) GO TO 11
  2585.       X4=XW2
  2586.       Y4=YW2
  2587.       Z4=ZW2
  2588. 11    XW1=XS1
  2589.       YW1=YS1
  2590.       ZW1=ZS1
  2591.       XW2=XS2
  2592.       YW2=YS2
  2593.       ZW2=ZS2
  2594.       IF (NS.EQ.4) GO TO 12
  2595.       X4=XW1+X3-XW2
  2596.       Y4=YW1+Y3-YW2
  2597.       Z4=ZW1+Z3-ZW2
  2598. 12    WRITE(3,51)  I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2
  2599.       WRITE(3,39)  X3,Y3,Z3,X4,Y4,Z4
  2600.       GO TO 16
  2601. C
  2602. C     GENERATE MULTIPLE-PATCH SURFACE
  2603. C
  2604. 13    I1=M+1
  2605.       WRITE(3,59)  I1,IPT(2),XW1,YW1,ZW1,XW2,YW2,ZW2,ITG,NS
  2606.       IF (ITG.LT.1.OR.NS.LT.1) GO TO 17
  2607. 14    CALL READGM(2,GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4,DUMMY)
  2608.       IF (NS.NE.2.AND.ITG.LT.1) GO TO 15
  2609.       X4=XW1+X3-XW2
  2610.       Y4=YW1+Y3-YW2
  2611.       Z4=ZW1+Z3-ZW2
  2612. 15    WRITE(3,39)  X3,Y3,Z3,X4,Y4,Z4
  2613.       IF (GM.NE.ATST(11)) GO TO 17
  2614. 16    CALL PATCH (ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,X3,Y3,Z3,X4,Y4,Z4)
  2615.       GO TO 1
  2616. 17    WRITE(3,60)
  2617.       STOP
  2618. C
  2619. C     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
  2620. C
  2621. 18    IY=NS/10
  2622.       IZ=NS-IY*10
  2623.       IX=IY/10
  2624.       IY=IY-IX*10
  2625.       IF (IX.NE.0) IX=1
  2626.       IF (IY.NE.0) IY=1
  2627.       IF (IZ.NE.0) IZ=1
  2628.       WRITE(3,44)  IFX(IX+1),IFY(IY+1),IFZ(IZ+1),ITG
  2629.       GO TO 20
  2630. 19    WRITE(3,45)  NS,ITG
  2631.       IX=-1
  2632. 20    CALL REFLC (IX,IY,IZ,ITG,NS)
  2633.       GO TO 1
  2634. C
  2635. C     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.
  2636. C
  2637. 21    IF (N.LT.N2) GO TO 23
  2638.       DO 22 I=N2,N
  2639.       X(I)=X(I)*XW1
  2640.       Y(I)=Y(I)*XW1
  2641.       Z(I)=Z(I)*XW1
  2642.       X2(I)=X2(I)*XW1
  2643.       Y2(I)=Y2(I)*XW1
  2644.       Z2(I)=Z2(I)*XW1
  2645. 22    BI(I)=BI(I)*XW1
  2646. 23    IF (M.LT.M2) GO TO 25
  2647.       YW1=XW1*XW1
  2648.       IX=LD+1-M
  2649.       IY=LD-M1
  2650.       DO 24 I=IX,IY
  2651.       X(I)=X(I)*XW1
  2652.       Y(I)=Y(I)*XW1
  2653.       Z(I)=Z(I)*XW1
  2654. 24    BI(I)=BI(I)*YW1
  2655. 25    WRITE(3,46)  XW1
  2656.       GO TO 1
  2657. C
  2658. C     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.
  2659. C
  2660. 26    WRITE(3,47)  ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
  2661.       XW1=XW1*TA
  2662.       YW1=YW1*TA
  2663.       ZW1=ZW1*TA
  2664.       CALL MOVE (XW1,YW1,ZW1,XW2,YW2,ZW2,INT(RAD+.5),NS,ITG)
  2665.       GO TO 1
  2666. C
  2667. C     READ NUMERICAL GREEN'S FUNCTION TAPE
  2668. C
  2669. 27    IF (N+M.EQ.0) GO TO 28
  2670.       WRITE(3,52)
  2671.       STOP
  2672. 28    CALL GFIL (ITG)
  2673.       NPSAV=NP
  2674.       MPSAV=MP
  2675.       IPSAV=IPSYM
  2676.       GO TO 1
  2677. C
  2678. C     TERMINATE STRUCTURE GEOMETRY INPUT.
  2679. C
  2680. C***
  2681. 29    IF(NS.EQ.0) GO TO 290
  2682.       IPLP1=1
  2683.       IPLP2=1
  2684. 290   IX=N1+M1
  2685. C***
  2686.       IF (IX.EQ.0) GO TO 30
  2687.       NP=N
  2688.       MP=M
  2689.       IPSYM=0
  2690. 30    CALL CONECT (ITG)
  2691.       IF (IX.EQ.0) GO TO 31
  2692.       NP=NPSAV
  2693.       MP=MPSAV
  2694.       IPSYM=IPSAV
  2695. 31    IF (N+M.GT.LD) GO TO 37
  2696.       IF (N.EQ.0) GO TO 33
  2697.       WRITE(3,53)
  2698.       WRITE(3,54)
  2699.       DO 32 I=1,N
  2700.       XW1=X2(I)-X(I)
  2701.       YW1=Y2(I)-Y(I)
  2702.       ZW1=Z2(I)-Z(I)
  2703.       X(I)=(X(I)+X2(I))*.5
  2704.       Y(I)=(Y(I)+Y2(I))*.5
  2705.       Z(I)=(Z(I)+Z2(I))*.5
  2706.       XW2=XW1*XW1+YW1*YW1+ZW1*ZW1
  2707.       YW2=SQRT(XW2)
  2708.       YW2=(XW2/YW2+YW2)*.5
  2709.       SI(I)=YW2
  2710.       CAB(I)=XW1/YW2
  2711.       SAB(I)=YW1/YW2
  2712.       XW2=ZW1/YW2
  2713.       IF (XW2.GT.1.) XW2=1.
  2714.       IF (XW2.LT.-1.) XW2=-1.
  2715.       SALP(I)=XW2
  2716.       XW2=ASIN(XW2)*TD
  2717.       YW2=ATGN2(YW1,XW1)*TD
  2718.       WRITE(3,55) I,X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I,
  2719.      1ICON2(I),ITAG(I)
  2720. C***
  2721.       IF(IPLP1.NE.1) GO TO 320
  2722.       WRITE(8,*)X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I,ICON2(I)
  2723. 320   CONTINUE
  2724. C***
  2725.       IF (SI(I).GT.1.D-20.AND.BI(I).GT.0.) GO TO 32
  2726.       WRITE(3,56)
  2727.       STOP
  2728. 32    CONTINUE
  2729. 33    IF (M.EQ.0) GO TO 35
  2730.       WRITE(3,57)
  2731.       J=LD+1
  2732.       DO 34 I=1,M
  2733.       J=J-1
  2734.       XW1=(T1Y(J)*T2Z(J)-T1Z(J)*T2Y(J))*SALP(J)
  2735.       YW1=(T1Z(J)*T2X(J)-T1X(J)*T2Z(J))*SALP(J)
  2736.       ZW1=(T1X(J)*T2Y(J)-T1Y(J)*T2X(J))*SALP(J)
  2737.       WRITE(3,58) I,X(J),Y(J),Z(J),XW1,YW1,ZW1,BI(J),T1X(J),T1Y(J),
  2738.      1T1Z(J),T2X(J),T2Y(J),T2Z(J)
  2739. 34    CONTINUE
  2740. 35    RETURN
  2741. 36    WRITE(3,48)
  2742.       WRITE(3,49)  GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
  2743.       STOP
  2744. 37    WRITE(3,50)
  2745.       STOP
  2746. C
  2747. 38    FORMAT (1X,I5,2X,12HARC RADIUS =,F9.5,2X,4HFROM,F8.3,3H TO,F8.3,8H
  2748.      1 DEGREES,11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  2749. 39    FORMAT (6X,3F11.5,1X,3F11.5)
  2750. 40    FORMAT (////,33X,35H- - - STRUCTURE SPECIFICATION - - -,//,37X,28H
  2751.      1COORDINATES MUST BE INPUT IN,/,37X,29HMETERS OR BE SCALED TO METER
  2752.      2S,/,37X,31HBEFORE STRUCTURE INPUT IS ENDED,//)
  2753. 41    FORMAT (2X,4HWIRE,79X,6HNO. OF,4X,5HFIRST,2X,4HLAST,5X,3HTAG,/,2X,
  2754.      13HNO.,8X,2HX1,9X,2HY1,9X,2HZ1,10X,2HX2,9X,2HY2,9X,2HZ2,6X,6HRADIUS
  2755.      2,3X,4HSEG.,5X,4HSEG.,3X,4HSEG.,5X,3HNO.)
  2756. 42    FORMAT (A2,I3,I5,7F10.5)
  2757. 43    FORMAT (1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  2758. 44    FORMAT (6X,34HSTRUCTURE REFLECTED ALONG THE AXES,3(1X,A1),22H.  TA
  2759.      1GS INCREMENTED BY,I5)
  2760. 45    FORMAT (6X,30HSTRUCTURE ROTATED ABOUT Z-AXIS,I3,30H TIMES.  LABELS
  2761.      1 INCREMENTED BY,I5)
  2762. 46    FORMAT (6X,26HSTRUCTURE SCALED BY FACTOR,F10.5)
  2763. 47    FORMAT (6X,49HTHE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X
  2764.      1,I3,I5,7F10.5)
  2765. 48    FORMAT (25H GEOMETRY DATA CARD ERROR)
  2766. 49    FORMAT (1X,A2,I3,I5,7F10.5)
  2767. 50    FORMAT (69H NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI
  2768.      1MENSION LIMIT.)
  2769. 51    FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
  2770. 52    FORMAT (44H ERROR - GF MUST BE FIRST GEOMETRY DATA CARD)
  2771. 53    FORMAT (////33X,33H- - - - SEGMENTATION DATA - - - -,//,40X,21HCOO
  2772.      1RDINATES IN METERS,//,25X,50HI+ AND I- INDICATE THE SEGMENTS BEFOR
  2773.      2E AND AFTER I,//)
  2774. 54    FORMAT (2X,4HSEG.,3X,26HCOORDINATES OF SEG. CENTER,5X,4HSEG.,5X,18
  2775.      1HORIENTATION ANGLES,4X,4HWIRE,4X,15HCONNECTION DATA,3X,3HTAG,/,2X,
  2776.      23HNO.,7X,1HX,9X,1HY,9X,1HZ,7X,6HLENGTH,5X,5HALPHA,5X,4HBETA,6X,6HR
  2777.      3ADIUS,4X,2HI-,3X,1HI,4X,2HI+,4X,3HNO.)
  2778. 55    FORMAT (1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
  2779. 56    FORMAT (19H SEGMENT DATA ERROR)
  2780. 57    FORMAT (////,44X,30H- - - SURFACE PATCH DATA - - -,//,49X,21HCOORD
  2781.      1INATES IN METERS,//,1X,5HPATCH,5X,22HCOORD. OF PATCH CENTER,7X,18H
  2782.      2UNIT NORMAL VECTOR,6X,5HPATCH,12X,34HCOMPONENTS OF UNIT TANGENT VE
  2783.      3CTORS,/,2X,3HNO.,6X,1HX,9X,1HY,9X,1HZ,9X,1HX,7X,1HY,7X,1HZ,7X,4HAR
  2784.      4EA,7X,2HX1,6X,2HY1,6X,2HZ1,7X,2HX2,6X,2HY2,6X,2HZ2)
  2785. 58    FORMAT (1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4)
  2786. 59    FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,9HSURFACE -,I4,3H BY,I3
  2787.      1,8H PATCHES)
  2788. 60    FORMAT (17H PATCH DATA ERROR)
  2789. 61    FORMAT (9X,43HABOVE WIRE IS TAPERED.  SEG. LENGTH RATIO =,F9.5,/,3
  2790.      13X,11HRADIUS FROM,F9.5,3H TO,F9.5)
  2791.       END
  2792.       FUNCTION DB10 (X)
  2793. C ***
  2794. C     DOUBLE PRECISION 6/4/85
  2795. C
  2796.       IMPLICIT REAL*8(A-H,O-Z)
  2797. C ***
  2798. C
  2799. C     FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
  2800. C
  2801.       F=10.
  2802.       GO TO 1
  2803.       ENTRY DB20(X)
  2804.       F=20.
  2805. 1     IF (X.LT.1.D-20) GO TO 2
  2806.       DB10=F*LOG10(X)
  2807.       RETURN
  2808. 2     DB10=-999.99
  2809.       RETURN
  2810.       END
  2811.       SUBROUTINE EFLD (XI,YI,ZI,AI,IJ)
  2812. C ***
  2813. C     DOUBLE PRECISION 6/4/85
  2814. C
  2815.       IMPLICIT REAL*8(A-H,O-Z)
  2816. C ***
  2817. C
  2818. C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
  2819. C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.
  2820. C
  2821.       COMPLEX*16 TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,EXK,EYK,EZK,EXS,EYS
  2822.      1,EZS,EXC,EYC,EZC,EPX,EPY,ZRATI,REFS,REFPS,ZRSIN,ZRATX,T1,ZSCRN
  2823.      2,ZRATI2,TEZS,TERS,TEZC,TERC,TEZK,TERK,EGND,FRATI
  2824.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  2825.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  2826.       COMMON /GND/ ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR
  2827.      1,IPERF,T1,T2
  2828.       COMMON /INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
  2829.       DIMENSION EGND(9)
  2830.       EQUIVALENCE (EGND(1),TXK), (EGND(2),TYK), (EGND(3),TZK), (EGND(4),
  2831.      1TXS), (EGND(5),TYS), (EGND(6),TZS), (EGND(7),TXC), (EGND(8),TYC),
  2832.      2(EGND(9),TZC)
  2833.       DATA ETA/376.73/,PI/3.141592654D+0/,TP/6.283185308D+0/
  2834.       XIJ=XI-XJ
  2835.       YIJ=YI-YJ
  2836.       IJX=IJ
  2837.       RFL=-1.
  2838.       DO 12 IP=1,KSYMP
  2839.       IF (IP.EQ.2) IJX=1
  2840.       RFL=-RFL
  2841.       SALPR=SALPJ*RFL
  2842.       ZIJ=ZI-RFL*ZJ
  2843.       ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
  2844.       RHOX=XIJ-CABJ*ZP
  2845.       RHOY=YIJ-SABJ*ZP
  2846.       RHOZ=ZIJ-SALPR*ZP
  2847.       RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
  2848.       IF (RH.GT.1.D-10) GO TO 1
  2849.       RHOX=0.
  2850.       RHOY=0.
  2851.       RHOZ=0.
  2852.       GO TO 2
  2853. 1     RHOX=RHOX/RH
  2854.       RHOY=RHOY/RH
  2855.       RHOZ=RHOZ/RH
  2856. 2     R=SQRT(ZP*ZP+RH*RH)
  2857.       IF (R.LT.RKH) GO TO 3
  2858. C
  2859. C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
  2860. C
  2861.       RMAG=TP*R
  2862.       CTH=ZP/R
  2863.       PX=RH/R
  2864.       TXK=DCMPLX(COS(RMAG),-SIN(RMAG))
  2865.       PY=TP*R*R
  2866.       TYK=ETA*CTH*TXK*DCMPLX(1.D+0,-1.D+0/RMAG)/PY
  2867.       TZK=ETA*PX*TXK*DCMPLX(1.D+0,RMAG-1.D+0/RMAG)/(2.*PY)
  2868.       TEZK=TYK*CTH-TZK*PX
  2869.       TERK=TYK*PX+TZK*CTH
  2870.       RMAG=SIN(PI*S)/PI
  2871.       TEZC=TEZK*RMAG
  2872.       TERC=TERK*RMAG
  2873.       TEZK=TEZK*S
  2874.       TERK=TERK*S
  2875.       TXS=(0.,0.)
  2876.       TYS=(0.,0.)
  2877.       TZS=(0.,0.)
  2878.       GO TO 6
  2879. 3     IF (IEXK.EQ.1) GO TO 4
  2880. C
  2881. C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
  2882. C
  2883.       CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK)
  2884.       GO TO 5
  2885. 4     CALL EKSCX (B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,TE
  2886.      1RK)
  2887. 5     TXS=TEZS*CABJ+TERS*RHOX
  2888.       TYS=TEZS*SABJ+TERS*RHOY
  2889.       TZS=TEZS*SALPR+TERS*RHOZ
  2890. 6     TXK=TEZK*CABJ+TERK*RHOX
  2891.       TYK=TEZK*SABJ+TERK*RHOY
  2892.       TZK=TEZK*SALPR+TERK*RHOZ
  2893.       TXC=TEZC*CABJ+TERC*RHOX
  2894.       TYC=TEZC*SABJ+TERC*RHOY
  2895.       TZC=TEZC*SALPR+TERC*RHOZ
  2896.       IF (IP.NE.2) GO TO 11
  2897.       IF (IPERF.GT.0) GO TO 10
  2898.       ZRATX=ZRATI
  2899.       RMAG=R
  2900.       XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
  2901. C
  2902. C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
  2903. C
  2904.       IF (NRADL.EQ.0) GO TO 7
  2905.       XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ)
  2906.       YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ)
  2907.       RHOSPC=SQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2)
  2908.       IF (RHOSPC.GT.SCRWL) GO TO 7
  2909.       ZSCRN=T1*RHOSPC*LOG(RHOSPC/T2)
  2910.       ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
  2911. 7     IF (XYMAG.GT.1.D-6) GO TO 8
  2912. C
  2913. C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
  2914. C
  2915.       PX=0.
  2916.       PY=0.
  2917.       CTH=1.
  2918.       ZRSIN=(1.,0.)
  2919.       GO TO 9
  2920. 8     PX=-YIJ/XYMAG
  2921.       PY=XIJ/XYMAG
  2922.       CTH=ZIJ/RMAG
  2923.       ZRSIN=SQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH))
  2924. 9     REFS=(CTH-ZRATX*ZRSIN)/(CTH+ZRATX*ZRSIN)
  2925.       REFPS=-(ZRATX*CTH-ZRSIN)/(ZRATX*CTH+ZRSIN)
  2926.       REFPS=REFPS-REFS
  2927.       EPY=PX*TXK+PY*TYK
  2928.       EPX=PX*EPY
  2929.       EPY=PY*EPY
  2930.       TXK=REFS*TXK+REFPS*EPX
  2931.       TYK=REFS*TYK+REFPS*EPY
  2932.       TZK=REFS*TZK
  2933.       EPY=PX*TXS+PY*TYS
  2934.       EPX=PX*EPY
  2935.       EPY=PY*EPY
  2936.       TXS=REFS*TXS+REFPS*EPX
  2937.       TYS=REFS*TYS+REFPS*EPY
  2938.       TZS=REFS*TZS
  2939.       EPY=PX*TXC+PY*TYC
  2940.       EPX=PX*EPY
  2941.       EPY=PY*EPY
  2942.       TXC=REFS*TXC+REFPS*EPX
  2943.       TYC=REFS*TYC+REFPS*EPY
  2944.       TZC=REFS*TZC
  2945. 10    EXK=EXK-TXK*FRATI
  2946.       EYK=EYK-TYK*FRATI
  2947.       EZK=EZK-TZK*FRATI
  2948.       EXS=EXS-TXS*FRATI
  2949.       EYS=EYS-TYS*FRATI
  2950.       EZS=EZS-TZS*FRATI
  2951.       EXC=EXC-TXC*FRATI
  2952.       EYC=EYC-TYC*FRATI
  2953.       EZC=EZC-TZC*FRATI
  2954.       GO TO 12
  2955. 11    EXK=TXK
  2956.       EYK=TYK
  2957.       EZK=TZK
  2958.       EXS=TXS
  2959.       EYS=TYS
  2960.       EZS=TZS
  2961.       EXC=TXC
  2962.       EYC=TYC
  2963.       EZC=TZC
  2964. 12    CONTINUE
  2965.       IF (IPERF.EQ.2) GO TO 13
  2966.       RETURN
  2967. C
  2968. C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON
  2969. C
  2970. 13    SN=SQRT(CABJ*CABJ+SABJ*SABJ)
  2971.       IF (SN.LT.1.D-5) GO TO 14
  2972.       XSN=CABJ/SN
  2973.       YSN=SABJ/SN
  2974.       GO TO 15
  2975. 14    SN=0.
  2976.       XSN=1.
  2977.       YSN=0.
  2978. C
  2979. C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
  2980. C
  2981. 15    ZIJ=ZI+ZJ
  2982.       SALPR=-SALPJ
  2983.       RHOX=SABJ*ZIJ-SALPR*YIJ
  2984.       RHOY=SALPR*XIJ-CABJ*ZIJ
  2985.       RHOZ=CABJ*YIJ-SABJ*XIJ
  2986.       RH=RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ
  2987.       IF (RH.GT.1.D-10) GO TO 16
  2988.       XO=XI-AI*YSN
  2989.       YO=YI+AI*XSN
  2990.       ZO=ZI
  2991.       GO TO 17
  2992. 16    RH=AI/SQRT(RH)
  2993.       IF (RHOZ.LT.0.) RH=-RH
  2994.       XO=XI+RH*RHOX
  2995.       YO=YI+RH*RHOY
  2996.       ZO=ZI+RH*RHOZ
  2997. 17    R=XIJ*XIJ+YIJ*YIJ+ZIJ*ZIJ
  2998.       IF (R.GT..95) GO TO 18
  2999. C
  3000. C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
  3001. C
  3002.       ISNOR=1
  3003.       DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK)
  3004.       DMIN=.01*SQRT(DMIN)
  3005.       SHAF=.5*S
  3006.       CALL ROM2 (-SHAF,SHAF,EGND,DMIN)
  3007.       GO TO 19
  3008. C
  3009. C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
  3010. C
  3011. 18    ISNOR=2
  3012.       CALL SFLDS (0.,EGND)
  3013.       GO TO 22
  3014. 19    ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
  3015.       RH=R-ZP*ZP
  3016.       IF (RH.GT.1.D-10) GO TO 20
  3017.       DMIN=0.
  3018.       GO TO 21
  3019. 20    DMIN=SQRT(RH/(RH+AI*AI))
  3020. 21    IF (DMIN.GT..95) GO TO 22
  3021.       PX=1.-DMIN
  3022.       TERK=(TXK*CABJ+TYK*SABJ+TZK*SALPR)*PX
  3023.       TXK=DMIN*TXK+TERK*CABJ
  3024.       TYK=DMIN*TYK+TERK*SABJ
  3025.       TZK=DMIN*TZK+TERK*SALPR
  3026.       TERS=(TXS*CABJ+TYS*SABJ+TZS*SALPR)*PX
  3027.       TXS=DMIN*TXS+TERS*CABJ
  3028.       TYS=DMIN*TYS+TERS*SABJ
  3029.       TZS=DMIN*TZS+TERS*SALPR
  3030.       TERC=(TXC*CABJ+TYC*SABJ+TZC*SALPR)*PX
  3031.       TXC=DMIN*TXC+TERC*CABJ
  3032.       TYC=DMIN*TYC+TERC*SABJ
  3033.       TZC=DMIN*TZC+TERC*SALPR
  3034. 22    EXK=EXK+TXK
  3035.       EYK=EYK+TYK
  3036.       EZK=EZK+TZK
  3037.       EXS=EXS+TXS
  3038.       EYS=EYS+TYS
  3039.       EZS=EZS+TZS
  3040.       EXC=EXC+TXC
  3041.       EYC=EYC+TYC
  3042.       EZC=EZC+TZC
  3043.       RETURN
  3044.       END
  3045.       SUBROUTINE EKSC (S,Z,RH,XK,IJ,EZS,ERS,EZC,ERC,EZK,ERK)
  3046. C ***
  3047. C     DOUBLE PRECISION 6/4/85
  3048. C
  3049.       IMPLICIT REAL*8(A-H,O-Z)
  3050. C ***
  3051. C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
  3052. C     THIN WIRE APPROXIMATION.
  3053.       COMPLEX*16 CON,GZ1,GZ2,GP1,GP2,GZP1,GZP2,EZS,ERS,EZC,ERC,EZK,ERK
  3054.       COMMON /TMI/ ZPK,RKB2,IJX
  3055.       DIMENSION CONX(2)
  3056.       EQUIVALENCE (CONX,CON)
  3057.       DATA CONX/0.,4.771341189D+0/
  3058.       IJX=IJ
  3059.       ZPK=XK*Z
  3060.       RHK=XK*RH
  3061.       RKB2=RHK*RHK
  3062.       SH=.5*S
  3063.       SHK=XK*SH
  3064.       SS=SIN(SHK)
  3065.       CS=COS(SHK)
  3066.       Z2=SH-Z
  3067.       Z1=-(SH+Z)
  3068.       CALL GX (Z1,RH,XK,GZ1,GP1)
  3069.       CALL GX (Z2,RH,XK,GZ2,GP2)
  3070.       GZP1=GP1*Z1
  3071.       GZP2=GP2*Z2
  3072.       EZS=CON*((GZ2-GZ1)*CS*XK-(GZP2+GZP1)*SS)
  3073.       EZC=-CON*((GZ2+GZ1)*SS*XK+(GZP2-GZP1)*CS)
  3074.       ERK=CON*(GP2-GP1)*RH
  3075.       CALL INTX (-SHK,SHK,RHK,IJ,CINT,SINT)
  3076.       EZK=-CON*(GZP2-GZP1+XK*XK*DCMPLX(CINT,-SINT))
  3077.       GZP1=GZP1*Z1
  3078.       GZP2=GZP2*Z2
  3079.       IF (RH.LT.1.D-10) GO TO 1
  3080.       ERS=-CON*((GZP2+GZP1+GZ2+GZ1)*SS-(Z2*GZ2-Z1*GZ1)*CS*XK)/RH
  3081.       ERC=-CON*((GZP2-GZP1+GZ2-GZ1)*CS+(Z2*GZ2+Z1*GZ1)*SS*XK)/RH
  3082.       RETURN
  3083. 1     ERS=(0.,0.)
  3084.       ERC=(0.,0.)
  3085.       RETURN
  3086.       END
  3087.       SUBROUTINE EKSCX (BX,S,Z,RHX,XK,IJ,INX1,INX2,EZS,ERS,EZC,ERC,EZK,E
  3088.      1RK)
  3089. C ***
  3090. C     DOUBLE PRECISION 6/4/85
  3091. C
  3092.       IMPLICIT REAL*8(A-H,O-Z)
  3093. C ***
  3094. C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
  3095. C     EXTENDED THIN WIRE APPROXIMATION.
  3096.       COMPLEX*16 CON,GZ1,GZ2,GZP1,GZP2,GR1,GR2,GRP1,GRP2,EZS,EZC,ERS,ERC
  3097.      1,GRK1,GRK2,EZK,ERK,GZZ1,GZZ2
  3098.       COMMON /TMI/ ZPK,RKB2,IJX
  3099.       DIMENSION CONX(2)
  3100.       EQUIVALENCE (CONX,CON)
  3101.       DATA CONX/0.,4.771341189D+0/
  3102.       IF (RHX.LT.BX) GO TO 1
  3103.       RH=RHX
  3104.       B=BX
  3105.       IRA=0
  3106.       GO TO 2
  3107. 1     RH=BX
  3108.       B=RHX
  3109.       IRA=1
  3110. 2     SH=.5*S
  3111.       IJX=IJ
  3112.       ZPK=XK*Z
  3113.       RHK=XK*RH
  3114.       RKB2=RHK*RHK
  3115.       SHK=XK*SH
  3116.       SS=SIN(SHK)
  3117.       CS=COS(SHK)
  3118.       Z2=SH-Z
  3119.       Z1=-(SH+Z)
  3120.       A2=B*B
  3121.       IF (INX1.EQ.2) GO TO 3
  3122.       CALL GXX (Z1,RH,B,A2,XK,IRA,GZ1,GZP1,GR1,GRP1,GRK1,GZZ1)
  3123.       GO TO 4
  3124. 3     CALL GX (Z1,RHX,XK,GZ1,GRK1)
  3125.       GZP1=GRK1*Z1
  3126.       GR1=GZ1/RHX
  3127.       GRP1=GZP1/RHX
  3128.       GRK1=GRK1*RHX
  3129.       GZZ1=(0.,0.)
  3130. 4     IF (INX2.EQ.2) GO TO 5
  3131.       CALL GXX (Z2,RH,B,A2,XK,IRA,GZ2,GZP2,GR2,GRP2,GRK2,GZZ2)
  3132.       GO TO 6
  3133. 5     CALL GX (Z2,RHX,XK,GZ2,GRK2)
  3134.       GZP2=GRK2*Z2
  3135.       GR2=GZ2/RHX
  3136.       GRP2=GZP2/RHX
  3137.       GRK2=GRK2*RHX
  3138.       GZZ2=(0.,0.)
  3139. 6     EZS=CON*((GZ2-GZ1)*CS*XK-(GZP2+GZP1)*SS)
  3140.       EZC=-CON*((GZ2+GZ1)*SS*XK+(GZP2-GZP1)*CS)
  3141.       ERS=-CON*((Z2*GRP2+Z1*GRP1+GR2+GR1)*SS-(Z2*GR2-Z1*GR1)*CS*XK)
  3142.       ERC=-CON*((Z2*GRP2-Z1*GRP1+GR2-GR1)*CS+(Z2*GR2+Z1*GR1)*SS*XK)
  3143.       ERK=CON*(GRK2-GRK1)
  3144.       CALL INTX (-SHK,SHK,RHK,IJ,CINT,SINT)
  3145.       BK=B*XK
  3146.       BK2=BK*BK*.25
  3147.       EZK=-CON*(GZP2-GZP1+XK*XK*(1.-BK2)*DCMPLX(CINT,-SINT)-BK2*(GZZ2-
  3148.      1GZZ1))
  3149.       RETURN
  3150.       END
  3151.       LOGICAL FUNCTION ENF(NUNIT)
  3152. C ***
  3153. C     DOUBLE PRECISION 6/4/85
  3154. C
  3155.       IMPLICIT REAL*8(A-H,O-Z)
  3156. C ***
  3157. C*********** THIS ROUTINE NOT USED ON VAX **************
  3158. C     IF (EOF,NUNIT) 1,2
  3159. 1     ENF=.TRUE.
  3160.       RETURN
  3161. 2     ENF=.FALSE.
  3162.       RETURN
  3163.       END
  3164.       SUBROUTINE ERROR
  3165. C ***
  3166. C     GET REASON FOR FILE ERROR (VAX ONLY).  ERROR SHOULD BE REDUCED TO 
  3167. C     "RETURN END" FOR MACINTOSH.
  3168. C
  3169.       IMPLICIT INTEGER (A-Z)
  3170.       CHARACTER MSG*80
  3171. C      CALL ERRSNS(FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
  3172. C      CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,)
  3173. C      CALL STR$UPCASE(MSG,MSG)
  3174.       IND=INDEX(MSG,',')
  3175.       TYPE 1,MSG(IND+2:MSGLEN)
  3176. 1     FORMAT(//,'  ****  ERROR  ****   ',//,5X,A,//)
  3177.       RETURN
  3178.       END
  3179.       SUBROUTINE ETMNS (P1,P2,P3,P4,P5,P6,IPR,E)
  3180. C ***
  3181. C     DOUBLE PRECISION 6/4/85
  3182. C
  3183.       INCLUDE 'NEC2DPAR.INC'
  3184.       IMPLICIT REAL*8(A-H,O-Z)
  3185. C ***
  3186. C
  3187. C     ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD
  3188. C     INCIDENT ON THE STRUCTURE.  E IS THE RIGHT HAND SIDE OF THE MATRIX
  3189. C     EQUATION.
  3190. C
  3191.       COMPLEX*16 E,CX,CY,CZ,VSANT,ER,ET,EZH,ERH,VQD,VQDS,ZRATI
  3192.      1,ZRATI2,RRV,RRH,T1,TT1,TT2,FRATI
  3193.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  3194.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  3195.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  3196.      &IPSYM
  3197.       COMMON /ANGL/ SALP(MAXSEG)
  3198.       COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
  3199.      130),NVQD,NSANT,NQDS
  3200.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  3201.      1IPERF,T1,T2
  3202.       DIMENSION CAB(1), SAB(1), E(2*MAXSEG)
  3203.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  3204.       EQUIVALENCE (CAB,ALP), (SAB,BET)
  3205.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  3206.      12), (T2Z,ITAG)
  3207.       DATA TP/6.283185308D+0/,RETA/2.654420938D-3/
  3208.       NEQ=N+2*M
  3209.       NQDS=0
  3210.       IF (IPR.GT.0.AND.IPR.NE.5) GO TO 5
  3211. C
  3212. C     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE
  3213. C
  3214.       DO 1 I=1,NEQ
  3215. 1     E(I)=(0.,0.)
  3216.       IF (NSANT.EQ.0) GO TO 3
  3217.       DO 2 I=1,NSANT
  3218.       IS=ISANT(I)
  3219. 2     E(IS)=-VSANT(I)/(SI(IS)*WLAM)
  3220. 3     IF (NVQD.EQ.0) RETURN
  3221.       DO 4 I=1,NVQD
  3222.       IS=IVQD(I)
  3223. 4     CALL QDSRC (IS,VQD(I),E)
  3224.       RETURN
  3225. 5     IF (IPR.GT.3) GO TO 19
  3226. C
  3227. C     INCIDENT PLANE WAVE, LINEARLY POLARIZED.
  3228. C
  3229.       CTH=COS(P1)
  3230.       STH=SIN(P1)
  3231.       CPH=COS(P2)
  3232.       SPH=SIN(P2)
  3233.       CET=COS(P3)
  3234.       SET=SIN(P3)
  3235.       PX=CTH*CPH*CET-SPH*SET
  3236.       PY=CTH*SPH*CET+CPH*SET
  3237.       PZ=-STH*CET
  3238.       WX=-STH*CPH
  3239.       WY=-STH*SPH
  3240.       WZ=-CTH
  3241.       QX=WY*PZ-WZ*PY
  3242.       QY=WZ*PX-WX*PZ
  3243.       QZ=WX*PY-WY*PX
  3244.       IF (KSYMP.EQ.1) GO TO 7
  3245.       IF (IPERF.EQ.1) GO TO 6
  3246.       RRV=SQRT(1.-ZRATI*ZRATI*STH*STH)
  3247.       RRH=ZRATI*CTH
  3248.       RRH=(RRH-RRV)/(RRH+RRV)
  3249.       RRV=ZRATI*RRV
  3250.       RRV=-(CTH-RRV)/(CTH+RRV)
  3251.       GO TO 7
  3252. 6     RRV=-(1.,0.)
  3253.       RRH=-(1.,0.)
  3254. 7     IF (IPR.GT.1) GO TO 13
  3255.       IF (N.EQ.0) GO TO 10
  3256.       DO 8 I=1,N
  3257.       ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
  3258. 8     E(I)=-(PX*CAB(I)+PY*SAB(I)+PZ*SALP(I))*DCMPLX(COS(ARG),SIN(ARG))
  3259.       IF (KSYMP.EQ.1) GO TO 10
  3260.       TT1=(PY*CPH-PX*SPH)*(RRH-RRV)
  3261.       CX=RRV*PX-TT1*SPH
  3262.       CY=RRV*PY+TT1*CPH
  3263.       CZ=-RRV*PZ
  3264.       DO 9 I=1,N
  3265.       ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
  3266. 9     E(I)=E(I)-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG),
  3267.      1SIN(ARG))
  3268. 10    IF (M.EQ.0) RETURN
  3269.       I=LD+1
  3270.       I1=N-1
  3271.       DO 11 IS=1,M
  3272.       I=I-1
  3273.       I1=I1+2
  3274.       I2=I1+1
  3275.       ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
  3276.       TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA
  3277.       E(I2)=(QX*T1X(I)+QY*T1Y(I)+QZ*T1Z(I))*TT1
  3278. 11    E(I1)=(QX*T2X(I)+QY*T2Y(I)+QZ*T2Z(I))*TT1
  3279.       IF (KSYMP.EQ.1) RETURN
  3280.       TT1=(QY*CPH-QX*SPH)*(RRV-RRH)
  3281.       CX=-(RRH*QX-TT1*SPH)
  3282.       CY=-(RRH*QY+TT1*CPH)
  3283.       CZ=RRH*QZ
  3284.       I=LD+1
  3285.       I1=N-1
  3286.       DO 12 IS=1,M
  3287.       I=I-1
  3288.       I1=I1+2
  3289.       I2=I1+1
  3290.       ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
  3291.       TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA
  3292.       E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1
  3293. 12    E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1
  3294.       RETURN
  3295. C
  3296. C     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.
  3297. C
  3298. 13    TT1=-(0.,1.)*P6
  3299.       IF (IPR.EQ.3) TT1=-TT1
  3300.       IF (N.EQ.0) GO TO 16
  3301.       CX=PX+TT1*QX
  3302.       CY=PY+TT1*QY
  3303.       CZ=PZ+TT1*QZ
  3304.       DO 14 I=1,N
  3305.       ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
  3306. 14    E(I)=-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG),SIN(ARG))
  3307.       IF (KSYMP.EQ.1) GO TO 16
  3308.       TT2=(CY*CPH-CX*SPH)*(RRH-RRV)
  3309.       CX=RRV*CX-TT2*SPH
  3310.       CY=RRV*CY+TT2*CPH
  3311.       CZ=-RRV*CZ
  3312.       DO 15 I=1,N
  3313.       ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
  3314. 15    E(I)=E(I)-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG),
  3315.      1SIN(ARG))
  3316. 16    IF (M.EQ.0) RETURN
  3317.       CX=QX-TT1*PX
  3318.       CY=QY-TT1*PY
  3319.       CZ=QZ-TT1*PZ
  3320.       I=LD+1
  3321.       I1=N-1
  3322.       DO 17 IS=1,M
  3323.       I=I-1
  3324.       I1=I1+2
  3325.       I2=I1+1
  3326.       ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
  3327.       TT2=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA
  3328.       E(I2)=(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT2
  3329. 17    E(I1)=(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT2
  3330.       IF (KSYMP.EQ.1) RETURN
  3331.       TT1=(CY*CPH-CX*SPH)*(RRV-RRH)
  3332.       CX=-(RRH*CX-TT1*SPH)
  3333.       CY=-(RRH*CY+TT1*CPH)
  3334.       CZ=RRH*CZ
  3335.       I=LD+1
  3336.       I1=N-1
  3337.       DO 18 IS=1,M
  3338.       I=I-1
  3339.       I1=I1+2
  3340.       I2=I1+1
  3341.       ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
  3342.       TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA
  3343.       E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1
  3344. 18    E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1
  3345.       RETURN
  3346. C
  3347. C     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.
  3348. C
  3349. 19    WZ=COS(P4)
  3350.       WX=WZ*COS(P5)
  3351.       WY=WZ*SIN(P5)
  3352.       WZ=SIN(P4)
  3353.       DS=P6*59.958
  3354.       DSH=P6/(2.*TP)
  3355.       NPM=N+M
  3356.       IS=LD+1
  3357.       I1=N-1
  3358.       DO 24 I=1,NPM
  3359.       II=I
  3360.       IF (I.LE.N) GO TO 20
  3361.       IS=IS-1
  3362.       II=IS
  3363.       I1=I1+2
  3364.       I2=I1+1
  3365. 20    PX=X(II)-P1
  3366.       PY=Y(II)-P2
  3367.       PZ=Z(II)-P3
  3368.       RS=PX*PX+PY*PY+PZ*PZ
  3369.       IF (RS.LT.1.D-30) GO TO 24
  3370.       R=SQRT(RS)
  3371.       PX=PX/R
  3372.       PY=PY/R
  3373.       PZ=PZ/R
  3374.       CTH=PX*WX+PY*WY+PZ*WZ
  3375.       STH=SQRT(1.-CTH*CTH)
  3376.       QX=PX-WX*CTH
  3377.       QY=PY-WY*CTH
  3378.       QZ=PZ-WZ*CTH
  3379.       ARG=SQRT(QX*QX+QY*QY+QZ*QZ)
  3380.       IF (ARG.LT.1.D-30) GO TO 21
  3381.       QX=QX/ARG
  3382.       QY=QY/ARG
  3383.       QZ=QZ/ARG
  3384.       GO TO 22
  3385. 21    QX=1.
  3386.       QY=0.
  3387.       QZ=0.
  3388. 22    ARG=-TP*R
  3389.       TT1=DCMPLX(COS(ARG),SIN(ARG))
  3390.       IF (I.GT.N) GO TO 23
  3391.       TT2=DCMPLX(1.D+0,-1.D+0/(R*TP))/RS
  3392.       ER=DS*TT1*TT2*CTH
  3393.       ET=.5*DS*TT1*((0.,1.)*TP/R+TT2)*STH
  3394.       EZH=ER*CTH-ET*STH
  3395.       ERH=ER*STH+ET*CTH
  3396.       CX=EZH*WX+ERH*QX
  3397.       CY=EZH*WY+ERH*QY
  3398.       CZ=EZH*WZ+ERH*QZ
  3399.       E(I)=-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))
  3400.       GO TO 24
  3401. 23    PX=WY*QZ-WZ*QY
  3402.       PY=WZ*QX-WX*QZ
  3403.       PZ=WX*QY-WY*QX
  3404.       TT2=DSH*TT1*DCMPLX(1./R,TP)/R*STH*SALP(II)
  3405.       CX=TT2*PX
  3406.       CY=TT2*PY
  3407.       CZ=TT2*PZ
  3408.       E(I2)=CX*T1X(II)+CY*T1Y(II)+CZ*T1Z(II)
  3409.       E(I1)=CX*T2X(II)+CY*T2Y(II)+CZ*T2Z(II)
  3410. 24    CONTINUE
  3411.       RETURN
  3412.       END
  3413.       SUBROUTINE FACGF (A,B,C,D,BX,IP,IX,NP,N1,MP,M1,N1C,N2C)
  3414. C ***
  3415. C     DOUBLE PRECISION 6/4/85
  3416. C
  3417.       IMPLICIT REAL*8(A-H,O-Z)
  3418. C ***
  3419. C     FACGF COMPUTES AND FACTORS D-C(INV(A)B).
  3420.       COMPLEX*16 A,B,C,D,BX,SUM
  3421.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  3422.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  3423.       DIMENSION A(1), B(N1C,1), C(N1C,1), D(N2C,1), BX(N1C,1), IP(1), IX
  3424.      1(1)
  3425.       IF (N2C.EQ.0) RETURN
  3426.       IBFL=14
  3427.       IF (ICASX.LT.3) GO TO 1
  3428. C     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16
  3429.       CALL REBLK (B,C,N1C,NPBX,N2C)
  3430.       IBFL=16
  3431. 1     NPB=NPBL
  3432.       IF (ICASX.EQ.2) REWIND 14
  3433. C     COMPUTE INV(A)B AND WRITE ON TAPE14
  3434.       DO 2 IB=1,NBBL
  3435.       IF (IB.EQ.NBBL) NPB=NLBL
  3436.       IF (ICASX.GT.1) READ (IBFL) ((BX(I,J),I=1,N1C),J=1,NPB)
  3437.       CALL SOLVES (A,IP,BX,N1C,NPB,NP,N1,MP,M1,13,13)
  3438.       IF (ICASX.EQ.2) REWIND 14
  3439.       IF (ICASX.GT.1) WRITE (14) ((BX(I,J),I=1,N1C),J=1,NPB)
  3440. 2     CONTINUE
  3441.       IF (ICASX.EQ.1) GO TO 3
  3442.       REWIND 11
  3443.       REWIND 12
  3444.       REWIND 15
  3445.       REWIND IBFL
  3446. 3     NPC=NPBL
  3447. C     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11
  3448.       DO 8 IC=1,NBBL
  3449.       IF (IC.EQ.NBBL) NPC=NLBL
  3450.       IF (ICASX.EQ.1) GO TO 4
  3451.       READ (15) ((C(I,J),I=1,N1C),J=1,NPC)
  3452.       READ (12) ((D(I,J),I=1,N2C),J=1,NPC)
  3453.       REWIND 14
  3454. 4     NPB=NPBL
  3455.       NIC=0
  3456.       DO 7 IB=1,NBBL
  3457.       IF (IB.EQ.NBBL) NPB=NLBL
  3458.       IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
  3459.       DO 6 I=1,NPB
  3460.       II=I+NIC
  3461.       DO 6 J=1,NPC
  3462.       SUM=(0.,0.)
  3463.       DO 5 K=1,N1C
  3464. 5     SUM=SUM+B(K,I)*C(K,J)
  3465. 6     D(II,J)=D(II,J)-SUM
  3466. 7     NIC=NIC+NPBL
  3467.       IF (ICASX.GT.1) WRITE (11) ((D(I,J),I=1,N2C),J=1,NPBL)
  3468. 8     CONTINUE
  3469.       IF (ICASX.EQ.1) GO TO 9
  3470.       REWIND 11
  3471.       REWIND 12
  3472.       REWIND 14
  3473.       REWIND 15
  3474. 9     N1CP=N1C+1
  3475. C     FACTOR D-C(INV(A)B)
  3476.       IF (ICASX.GT.1) GO TO 10
  3477.       CALL FACTR (N2C,D,IP(N1CP),N2C)
  3478.       GO TO 13
  3479. 10    IF (ICASX.EQ.4) GO TO 12
  3480.       NPB=NPBL
  3481.       IC=0
  3482.       DO 11 IB=1,NBBL
  3483.       IF (IB.EQ.NBBL) NPB=NLBL
  3484.       II=IC+1
  3485.       IC=IC+N2C*NPB
  3486. 11    READ (11) (B(I,1),I=II,IC)
  3487.       REWIND 11
  3488.       CALL FACTR (N2C,B,IP(N1CP),N2C)
  3489.       NIC=N2C*N2C
  3490.       WRITE (11) (B(I,1),I=1,NIC)
  3491.       REWIND 11
  3492.       GO TO 13
  3493. 12    NBLSYS=NBLSYM
  3494.       NPSYS=NPSYM
  3495.       NLSYS=NLSYM
  3496.       ICASS=ICASE
  3497.       NBLSYM=NBBL
  3498.       NPSYM=NPBL
  3499.       NLSYM=NLBL
  3500.       ICASE=3
  3501.       CALL FACIO (B,N2C,1,IX(N1CP),11,12,16,11)
  3502.       CALL LUNSCR (B,N2C,1,IP(N1CP),IX(N1CP),12,11,16)
  3503.       NBLSYM=NBLSYS
  3504.       NPSYM=NPSYS
  3505.       NLSYM=NLSYS
  3506.       ICASE=ICASS
  3507. 13    RETURN
  3508.       END
  3509.       SUBROUTINE FACIO (A,NROW,NOP,IP,IU1,IU2,IU3,IU4)
  3510. C ***
  3511. C     DOUBLE PRECISION 6/4/85
  3512. C
  3513.       IMPLICIT REAL*8(A-H,O-Z)
  3514. C ***
  3515. C
  3516. C     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION
  3517. C
  3518.       COMPLEX*16 A
  3519.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  3520.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  3521.       DIMENSION A(NROW,1), IP(NROW)
  3522.       IT=2*NPSYM*NROW
  3523.       NBM=NBLSYM-1
  3524.       I1=1
  3525.       I2=IT
  3526.       I3=I2+1
  3527.       I4=2*IT
  3528.       TIME=0.
  3529.       REWIND IU1
  3530.       REWIND IU2
  3531.       DO 3 KK=1,NOP
  3532.       KA=(KK-1)*NROW+1
  3533.       IFILE3=IU1
  3534.       IFILE4=IU3
  3535.       DO 2 IXBLK1=1,NBM
  3536.       REWIND IU3
  3537.       REWIND IU4
  3538.       CALL BLCKIN (A,IFILE3,I1,I2,1,17)
  3539.       IXBP=IXBLK1+1
  3540.       DO 1 IXBLK2=IXBP,NBLSYM
  3541.       CALL BLCKIN (A,IFILE3,I3,I4,1,18)
  3542.       CALL SECOND (T1)
  3543.       CALL LFACTR (A,NROW,IXBLK1,IXBLK2,IP(KA))
  3544.       CALL SECOND (T2)
  3545.       TIME=TIME+T2-T1
  3546.       IF (IXBLK2.EQ.IXBP) CALL BLCKOT (A,IU2,I1,I2,1,19)
  3547.       IF (IXBLK1.EQ.NBM.AND.IXBLK2.EQ.NBLSYM) IFILE4=IU2
  3548.       CALL BLCKOT (A,IFILE4,I3,I4,1,20)
  3549. 1     CONTINUE
  3550.       IFILE3=IU3
  3551.       IFILE4=IU4
  3552.       IF ((IXBLK1/2)*2.NE.IXBLK1) GO TO 2
  3553.       IFILE3=IU4
  3554.       IFILE4=IU3
  3555. 2     CONTINUE
  3556. 3     CONTINUE
  3557.       REWIND IU1
  3558.       REWIND IU2
  3559.       REWIND IU3
  3560.       REWIND IU4
  3561.       WRITE(3,4)  TIME
  3562.       RETURN
  3563. C
  3564. 4     FORMAT (35H CP TIME TAKEN FOR FACTORIZATION = ,1P,E12.5)
  3565.       END
  3566.       SUBROUTINE FACTR (N,A,IP,NDIM)
  3567. C ***
  3568. C     DOUBLE PRECISION 6/4/85
  3569. C
  3570.       INCLUDE 'NEC2DPAR.INC'
  3571.       IMPLICIT REAL*8(A-H,O-Z)
  3572. C ***
  3573. C
  3574. C     SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX
  3575. C     AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
  3576. C     PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN
  3577. C     NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN RALSTONS
  3578. C     TEXT.    (MATRIX TRANSPOSED.
  3579. C
  3580.       COMPLEX*16 A,D,ARJ
  3581.       DIMENSION A(NDIM,NDIM), IP(NDIM)
  3582.       COMMON /SCRATM/ D(2*MAXSEG)
  3583.       INTEGER R,RM1,RP1,PJ,PR
  3584.       IFLG=0
  3585.       DO 9 R=1,N
  3586. C
  3587. C     STEP 1
  3588. C
  3589.       DO 1 K=1,N
  3590.       D(K)=A(R,K)
  3591. 1     CONTINUE
  3592. C
  3593. C     STEPS 2 AND 3
  3594. C
  3595.       RM1=R-1
  3596.       IF (RM1.LT.1) GO TO 4
  3597.       DO 3 J=1,RM1
  3598.       PJ=IP(J)
  3599.       ARJ=D(PJ)
  3600.       A(R,J)=ARJ
  3601.       D(PJ)=D(J)
  3602.       JP1=J+1
  3603.       DO 2 I=JP1,N
  3604.       D(I)=D(I)-A(J,I)*ARJ
  3605. 2     CONTINUE
  3606. 3     CONTINUE
  3607. 4     CONTINUE
  3608. C
  3609. C     STEP 4
  3610. C
  3611.       DMAX=DREAL(D(R)*DCONJG(D(R)))
  3612.       IP(R)=R
  3613.       RP1=R+1
  3614.       IF (RP1.GT.N) GO TO 6
  3615.       DO 5 I=RP1,N
  3616.       ELMAG=DREAL(D(I)*DCONJG(D(I)))
  3617.       IF (ELMAG.LT.DMAX) GO TO 5
  3618.       DMAX=ELMAG
  3619.       IP(R)=I
  3620. 5     CONTINUE
  3621. 6     CONTINUE
  3622.       IF (DMAX.LT.1.D-10) IFLG=1
  3623.       PR=IP(R)
  3624.       A(R,R)=D(PR)
  3625.       D(PR)=D(R)
  3626. C
  3627. C     STEP 5
  3628. C
  3629.       IF (RP1.GT.N) GO TO 8
  3630.       ARJ=1./A(R,R)
  3631.       DO 7 I=RP1,N
  3632.       A(R,I)=D(I)*ARJ
  3633. 7     CONTINUE
  3634. 8     CONTINUE
  3635.       IF (IFLG.EQ.0) GO TO 9
  3636.       WRITE(3,10)  R,DMAX
  3637.       IFLG=0
  3638. 9     CONTINUE
  3639.       RETURN
  3640. C
  3641. 10    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)
  3642.       END
  3643.       SUBROUTINE FACTRS (NP,NROW,A,IP,IX,IU1,IU2,IU3,IU4)
  3644. C ***
  3645. C     DOUBLE PRECISION 6/4/85
  3646. C
  3647.       IMPLICIT REAL*8(A-H,O-Z)
  3648. C ***
  3649. C
  3650. C     FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM
  3651. C     MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR
  3652. C     MATRICIES.  IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE
  3653. C     COMPLETE MATRIX.
  3654. C
  3655.       COMPLEX*16 A
  3656.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  3657.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  3658.       DIMENSION A(1), IP(NROW), IX(NROW)
  3659.       NOP=NROW/NP
  3660.       IF (ICASE.GT.2) GO TO 2
  3661.       DO 1 KK=1,NOP
  3662.       KA=(KK-1)*NP+1
  3663. 1     CALL FACTR (NP,A(KA),IP(KA),NROW)
  3664.       RETURN
  3665. 2     IF (ICASE.GT.3) GO TO 3
  3666. C
  3667. C     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY
  3668. C     EXISTS.
  3669. C
  3670.       CALL FACIO (A,NROW,NOP,IX,IU1,IU2,IU3,IU4)
  3671.       CALL LUNSCR (A,NROW,NOP,IP,IX,IU2,IU3,IU4)
  3672.       RETURN
  3673. C
  3674. C     REWRITE THE MATRICES BY COLUMNS ON TAPE 13
  3675. C
  3676. 3     I2=2*NPBLK*NROW
  3677.       REWIND IU2
  3678.       DO 5 K=1,NOP
  3679.       REWIND IU1
  3680.       ICOLS=NPBLK
  3681.       IR2=K*NP
  3682.       IR1=IR2-NP+1
  3683.       DO 5 L=1,NBLOKS
  3684.       IF (NBLOKS.EQ.1.AND.K.GT.1) GO TO 4
  3685.       CALL BLCKIN (A,IU1,1,I2,1,602)
  3686.       IF (L.EQ.NBLOKS) ICOLS=NLAST
  3687. 4     IRR1=IR1
  3688.       IRR2=IR2
  3689.       DO 5 ICOLDX=1,ICOLS
  3690.       WRITE (IU2) (A(I),I=IRR1,IRR2)
  3691.       IRR1=IRR1+NROW
  3692.       IRR2=IRR2+NROW
  3693. 5     CONTINUE
  3694.       REWIND IU1
  3695.       REWIND IU2
  3696.       IF (ICASE.EQ.5) GO TO 8
  3697.       REWIND IU3
  3698.       IRR1=NP*NP
  3699.       DO 7 KK=1,NOP
  3700.       IR1=1-NP
  3701.       IR2=0
  3702.       DO 6 I=1,NP
  3703.       IR1=IR1+NP
  3704.       IR2=IR2+NP
  3705. 6     READ (IU2) (A(J),J=IR1,IR2)
  3706.       KA=(KK-1)*NP+1
  3707.       CALL FACTR (NP,A,IP(KA),NP)
  3708.       WRITE (IU3) (A(I),I=1,IRR1)
  3709. 7     CONTINUE
  3710.       REWIND IU2
  3711.       REWIND IU3
  3712.       RETURN
  3713. 8     I2=2*NPSYM*NP
  3714.       DO 10 KK=1,NOP
  3715.       J2=NPSYM
  3716.       DO 10 L=1,NBLSYM
  3717.       IF (L.EQ.NBLSYM) J2=NLSYM
  3718.       IR1=1-NP
  3719.       IR2=0
  3720.       DO 9 J=1,J2
  3721.       IR1=IR1+NP
  3722.       IR2=IR2+NP
  3723. 9     READ (IU2) (A(I),I=IR1,IR2)
  3724. 10    CALL BLCKOT (A,IU1,1,I2,1,193)
  3725.       REWIND IU1
  3726.       CALL FACIO (A,NP,NOP,IX,IU1,IU2,IU3,IU4)
  3727.       CALL LUNSCR (A,NP,NOP,IP,IX,IU2,IU3,IU4)
  3728.       RETURN
  3729.       END
  3730.       COMPLEX*16 FUNCTION FBAR(P)
  3731. C ***
  3732. C     DOUBLE PRECISION 6/4/85
  3733. C
  3734.       IMPLICIT REAL*8(A-H,O-Z)
  3735. C ***
  3736. C
  3737. C     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P
  3738. C
  3739.       COMPLEX*16 Z,ZS,SUM,POW,TERM,P,FJ
  3740.       DIMENSION FJX(2)
  3741.       EQUIVALENCE (FJ,FJX)
  3742.       DATA TOSP/1.128379167D+0/,ACCS/1.D-12/,SP/1.772453851D+0/
  3743.      1,FJX/0.,1./
  3744.       Z=FJ*SQRT(P)
  3745.       IF (ABS(Z).GT.3.) GO TO 3
  3746. C
  3747. C     SERIES EXPANSION
  3748. C
  3749.       ZS=Z*Z
  3750.       SUM=Z
  3751.       POW=Z
  3752.       DO 1 I=1,100
  3753.       POW=-POW*ZS/DFLOAT(I)
  3754.       TERM=POW/(2.*I+1.)
  3755.       SUM=SUM+TERM
  3756.       TMS=DREAL(TERM*DCONJG(TERM))
  3757.       SMS=DREAL(SUM*DCONJG(SUM))
  3758.       IF (TMS/SMS.LT.ACCS) GO TO 2
  3759. 1     CONTINUE
  3760. 2     FBAR=1.-(1.-SUM*TOSP)*Z*EXP(ZS)*SP
  3761.       RETURN
  3762. C
  3763. C     ASYMPTOTIC EXPANSION
  3764. C
  3765. 3     IF (DREAL(Z).GE.0.) GO TO 4
  3766.       MINUS=1
  3767.       Z=-Z
  3768.       GO TO 5
  3769. 4     MINUS=0
  3770. 5     ZS=.5/(Z*Z)
  3771.       SUM=(0.,0.)
  3772.       TERM=(1.,0.)
  3773.       DO 6 I=1,6
  3774.       TERM=-TERM*(2.*I-1.)*ZS
  3775. 6     SUM=SUM+TERM
  3776.       IF (MINUS.EQ.1) SUM=SUM-2.*SP*Z*EXP(Z*Z)
  3777.       FBAR=-SUM
  3778.       RETURN
  3779.       END
  3780.       SUBROUTINE FBLOCK (NROW,NCOL,IMAX,IRNGF,IPSYM)
  3781. C ***
  3782. C     DOUBLE PRECISION 6/4/85
  3783. C
  3784.       IMPLICIT REAL*8(A-H,O-Z)
  3785. C ***
  3786. C     FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY
  3787. C     MATRIX (A)
  3788.       COMPLEX*16 SSX,DETER
  3789.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  3790.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  3791.       COMMON /SMAT/ SSX(16,16)
  3792.       IMX1=IMAX-IRNGF
  3793.       IF (NROW*NCOL.GT.IMX1) GO TO 2
  3794.       NBLOKS=1
  3795.       NPBLK=NROW
  3796.       NLAST=NROW
  3797.       IMAT=NROW*NCOL
  3798.       IF (NROW.NE.NCOL) GO TO 1
  3799.       ICASE=1
  3800.       RETURN
  3801. 1     ICASE=2
  3802.       GO TO 5
  3803. 2     IF (NROW.NE.NCOL) GO TO 3
  3804.       ICASE=3
  3805.       NPBLK=IMAX/(2*NCOL)
  3806.       NPSYM=IMX1/NCOL
  3807.       IF (NPSYM.LT.NPBLK) NPBLK=NPSYM
  3808.       IF (NPBLK.LT.1) GO TO 12
  3809.       NBLOKS=(NROW-1)/NPBLK
  3810.       NLAST=NROW-NBLOKS*NPBLK
  3811.       NBLOKS=NBLOKS+1
  3812.       NBLSYM=NBLOKS
  3813.       NPSYM=NPBLK
  3814.       NLSYM=NLAST
  3815.       IMAT=NPBLK*NCOL
  3816.       WRITE(3,14)  NBLOKS,NPBLK,NLAST
  3817.       GO TO 11
  3818. 3     NPBLK=IMAX/NCOL
  3819.       IF (NPBLK.LT.1) GO TO 12
  3820.       IF (NPBLK.GT.NROW) NPBLK=NROW
  3821.       NBLOKS=(NROW-1)/NPBLK
  3822.       NLAST=NROW-NBLOKS*NPBLK
  3823.       NBLOKS=NBLOKS+1
  3824.       WRITE(3,14)  NBLOKS,NPBLK,NLAST
  3825.       IF (NROW*NROW.GT.IMX1) GO TO 4
  3826.       ICASE=4
  3827.       NBLSYM=1
  3828.       NPSYM=NROW
  3829.       NLSYM=NROW
  3830.       IMAT=NROW*NROW
  3831.       WRITE(3,15)
  3832.       GO TO 5
  3833. 4     ICASE=5
  3834.       NPSYM=IMAX/(2*NROW)
  3835.       NBLSYM=IMX1/NROW
  3836.       IF (NBLSYM.LT.NPSYM) NPSYM=NBLSYM
  3837.       IF (NPSYM.LT.1) GO TO 12
  3838.       NBLSYM=(NROW-1)/NPSYM
  3839.       NLSYM=NROW-NBLSYM*NPSYM
  3840.       NBLSYM=NBLSYM+1
  3841.       WRITE(3,16)  NBLSYM,NPSYM,NLSYM
  3842.       IMAT=NPSYM*NROW
  3843. 5     NOP=NCOL/NROW
  3844.       IF (NOP*NROW.NE.NCOL) GO TO 13
  3845.       IF (IPSYM.GT.0) GO TO 7
  3846. C
  3847. C     SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY.
  3848. C
  3849.       PHAZ=6.2831853072D+0/NOP
  3850.       DO 6 I=2,NOP
  3851.       DO 6 J=I,NOP
  3852.       ARG=PHAZ*DFLOAT(I-1)*DFLOAT(J-1)
  3853.       SSX(I,J)=DCMPLX(COS(ARG),SIN(ARG))
  3854. 6     SSX(J,I)=SSX(I,J)
  3855.       GO TO 11
  3856. C
  3857. C     SET UP SSX MATRIX FOR PLANE SYMMETRY
  3858. C
  3859. 7     KK=1
  3860.       SSX(1,1)=(1.,0.)
  3861.       IF ((NOP.EQ.2).OR.(NOP.EQ.4).OR.(NOP.EQ.8)) GO TO 8
  3862.       STOP
  3863. 8     KA=NOP/2
  3864.       IF (NOP.EQ.8) KA=3
  3865.       DO 10 K=1,KA
  3866.       DO 9 I=1,KK
  3867.       DO 9 J=1,KK
  3868.       DETER=SSX(I,J)
  3869.       SSX(I,J+KK)=DETER
  3870.       SSX(I+KK,J+KK)=-DETER
  3871. 9     SSX(I+KK,J)=DETER
  3872. 10    KK=KK*2
  3873. 11    RETURN
  3874. 12    WRITE(3,17)  NROW,NCOL
  3875.       STOP
  3876. 13    WRITE(3,18)  NROW,NCOL
  3877.       STOP
  3878. C
  3879. 14    FORMAT (//35H MATRIX FILE STORAGE -  NO. BLOCKS=,I5,19H COLUMNS PE
  3880.      1R BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5)
  3881. 15    FORMAT (25H SUBMATRICIES FIT IN CORE)
  3882. 16    FORMAT (38H SUBMATRIX PARTITIONING -  NO. BLOCKS=,I5,19H COLUMNS P
  3883.      1ER BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5)
  3884. 17    FORMAT (40H ERROR - INSUFFICIENT STORAGE FOR MATRIX,2I5)
  3885. 18    FORMAT (28H SYMMETRY ERROR - NROW,NCOL=,2I5)
  3886.       END
  3887.       SUBROUTINE FBNGF (NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11)
  3888. C ***
  3889. C     DOUBLE PRECISION 6/4/85
  3890. C
  3891.       IMPLICIT REAL*8(A-H,O-Z)
  3892. C ***
  3893. C     FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
  3894. C     OUT-OF-CORE STORAGE.
  3895.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  3896.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  3897.       IRESX=IRESRV-IMAT
  3898.       NBLN=NEQ*NEQ2
  3899.       NDLN=NEQ2*NEQ2
  3900.       NBCD=2*NBLN+NDLN
  3901.       IF (NBCD.GT.IRESX) GO TO 1
  3902.       ICASX=1
  3903.       IB11=IMAT+1
  3904.       GO TO 2
  3905. 1     IF (ICASE.LT.3) GO TO 3
  3906.       IF (NBCD.GT.IRESRV.OR.NBLN.GT.IRESX) GO TO 3
  3907.       ICASX=2
  3908.       IB11=1
  3909. 2     NBBX=1
  3910.       NPBX=NEQ
  3911.       NLBX=NEQ
  3912.       NBBL=1
  3913.       NPBL=NEQ2
  3914.       NLBL=NEQ2
  3915.       GO TO 5
  3916. 3     IR=IRESRV
  3917.       IF (ICASE.LT.3) IR=IRESX
  3918.       ICASX=3
  3919.       IF (NDLN.GT.IR) ICASX=4
  3920.       NBCD=2*NEQ+NEQ2
  3921.       NPBL=IR/NBCD
  3922.       NLBL=IR/(2*NEQ2)
  3923.       IF (NLBL.LT.NPBL) NPBL=NLBL
  3924.       IF (ICASE.LT.3) GO TO 4
  3925.       NLBL=IRESX/NEQ
  3926.       IF (NLBL.LT.NPBL) NPBL=NLBL
  3927. 4     IF (NPBL.LT.1) GO TO 6
  3928.       NBBL=(NEQ2-1)/NPBL
  3929.       NLBL=NEQ2-NBBL*NPBL
  3930.       NBBL=NBBL+1
  3931.       NBLN=NEQ*NPBL
  3932.       IR=IR-NBLN
  3933.       NPBX=IR/NEQ2
  3934.       IF (NPBX.GT.NEQ) NPBX=NEQ
  3935.       NBBX=(NEQ-1)/NPBX
  3936.       NLBX=NEQ-NBBX*NPBX
  3937.       NBBX=NBBX+1
  3938.       IB11=1
  3939.       IF (ICASE.LT.3) IB11=IMAT+1
  3940. 5     IC11=IB11+NBLN
  3941.       ID11=IC11+NBLN
  3942.       IX11=IMAT+1
  3943.       WRITE(3,11)  NEQ2
  3944.       IF (ICASX.EQ.1) RETURN
  3945.       WRITE(3,8)  ICASX
  3946.       WRITE(3,9)  NBBX,NPBX,NLBX
  3947.       WRITE(3,10)  NBBL,NPBL,NLBL
  3948.       RETURN
  3949. 6     WRITE(3,7)  IRESRV,IMAT,NEQ,NEQ2
  3950.       STOP
  3951. C
  3952. 7     FORMAT (55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
  3953.      1,24H  IRESRV,IMAT,NEQ,NEQ2 =,4I5)
  3954. 8     FORMAT (48H FILE STORAGE FOR NEW MATRIX SECTIONS -  ICASX =,I2)
  3955. 9     FORMAT (19H B FILLED BY ROWS -,15X,12HNO. BLOCKS =,I3,3X,16HROWS P
  3956.      1ER BLOCK =,I3,3X,20HROWS IN LAST BLOCK =,I3)
  3957. 10    FORMAT (32H B BY COLUMNS, C AND D BY ROWS -,2X,12HNO. BLOCKS =,I3,
  3958.      14X,15HR/C PER BLOCK =,I3,4X,19HR/C IN LAST BLOCK =,I3)
  3959. 11    FORMAT (//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4)
  3960.       END
  3961.       SUBROUTINE FFLD (THET,PHI,ETH,EPH)
  3962. C ***
  3963. C     DOUBLE PRECISION 6/4/85
  3964. C
  3965.       INCLUDE 'NEC2DPAR.INC'
  3966.       IMPLICIT REAL*8(A-H,O-Z)
  3967. C ***
  3968. C
  3969. C     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
  3970. C     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
  3971. C
  3972.       COMPLEX*16 CIX,CIY,CIZ,EXA,ETH,EPH,CONST,CCX,CCY,CCZ,CDP,CUR
  3973.       COMPLEX*16 ZRATI,ZRSIN,RRV,RRH,RRV1,RRH1,RRV2,RRH2,ZRATI2,TIX,TIY
  3974.      1,TIZ,T1,ZSCRN,EX,EY,EZ,GX,GY,GZ,FRATI
  3975.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  3976.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  3977.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  3978.      &IPSYM
  3979.       COMMON /ANGL/ SALP(MAXSEG)
  3980.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  3981.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  3982.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  3983.      1IPERF,T1,T2
  3984.       DIMENSION CAB(1), SAB(1), CONSX(2)
  3985.       EQUIVALENCE (CAB,ALP), (SAB,BET), (CONST,CONSX)
  3986.       DATA PI,TP,ETA/3.141592654D+0,6.283185308D+0,376.73/
  3987.       DATA CONSX/0.,-29.97922085D+0/
  3988.       PHX=-SIN(PHI)
  3989.       PHY=COS(PHI)
  3990.       ROZ=COS(THET)
  3991.       ROZS=ROZ
  3992.       THX=ROZ*PHY
  3993.       THY=-ROZ*PHX
  3994.       THZ=-SIN(THET)
  3995.       ROX=-THZ*PHY
  3996.       ROY=THZ*PHX
  3997.       IF (N.EQ.0) GO TO 20
  3998. C
  3999. C     LOOP FOR STRUCTURE IMAGE IF ANY
  4000. C
  4001.       DO 19 K=1,KSYMP
  4002. C
  4003. C     CALCULATION OF REFLECTION COEFFECIENTS
  4004. C
  4005.       IF (K.EQ.1) GO TO 4
  4006.       IF (IPERF.NE.1) GO TO 1
  4007. C
  4008. C     FOR PERFECT GROUND
  4009. C
  4010.       RRV=-(1.,0.)
  4011.       RRH=-(1.,0.)
  4012.       GO TO 2
  4013. C
  4014. C     FOR INFINITE PLANAR GROUND
  4015. C
  4016. 1     ZRSIN=SQRT(1.-ZRATI*ZRATI*THZ*THZ)
  4017.       RRV=-(ROZ-ZRATI*ZRSIN)/(ROZ+ZRATI*ZRSIN)
  4018.       RRH=(ZRATI*ROZ-ZRSIN)/(ZRATI*ROZ+ZRSIN)
  4019. 2     IF (IFAR.LE.1) GO TO 3
  4020. C
  4021. C     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
  4022. C
  4023.       RRV1=RRV
  4024.       RRH1=RRH
  4025.       TTHET=TAN(THET)
  4026.       IF (IFAR.EQ.4) GO TO 3
  4027.       ZRSIN=SQRT(1.-ZRATI2*ZRATI2*THZ*THZ)
  4028.       RRV2=-(ROZ-ZRATI2*ZRSIN)/(ROZ+ZRATI2*ZRSIN)
  4029.       RRH2=(ZRATI2*ROZ-ZRSIN)/(ZRATI2*ROZ+ZRSIN)
  4030.       DARG=-TP*2.*CH*ROZ
  4031. 3     ROZ=-ROZ
  4032.       CCX=CIX
  4033.       CCY=CIY
  4034.       CCZ=CIZ
  4035. 4     CIX=(0.,0.)
  4036.       CIY=(0.,0.)
  4037.       CIZ=(0.,0.)
  4038. C
  4039. C     LOOP OVER STRUCTURE SEGMENTS
  4040. C
  4041.       DO 17 I=1,N
  4042.       OMEGA=-(ROX*CAB(I)+ROY*SAB(I)+ROZ*SALP(I))
  4043.       EL=PI*SI(I)
  4044.       SILL=OMEGA*EL
  4045.       TOP=EL+SILL
  4046.       BOT=EL-SILL
  4047.       IF (ABS(OMEGA).LT.1.D-7) GO TO 5
  4048.       A=2.*SIN(SILL)/OMEGA
  4049.       GO TO 6
  4050. 5     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
  4051. 6     IF (ABS(TOP).LT.1.D-7) GO TO 7
  4052.       TOO=SIN(TOP)/TOP
  4053.       GO TO 8
  4054. 7     TOO=1.-TOP*TOP/6.
  4055. 8     IF (ABS(BOT).LT.1.D-7) GO TO 9
  4056.       BOO=SIN(BOT)/BOT
  4057.       GO TO 10
  4058. 9     BOO=1.-BOT*BOT/6.
  4059. 10    B=EL*(BOO-TOO)
  4060.       C=EL*(BOO+TOO)
  4061.       RR=A*AIR(I)+B*BII(I)+C*CIR(I)
  4062.       RI=A*AII(I)-B*BIR(I)+C*CII(I)
  4063.       ARG=TP*(X(I)*ROX+Y(I)*ROY+Z(I)*ROZ)
  4064.       IF (K.EQ.2.AND.IFAR.GE.2) GO TO 11
  4065.       EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
  4066. C
  4067. C     SUMMATION FOR FAR FIELD INTEGRAL
  4068. C
  4069.       CIX=CIX+EXA*CAB(I)
  4070.       CIY=CIY+EXA*SAB(I)
  4071.       CIZ=CIZ+EXA*SALP(I)
  4072.       GO TO 17
  4073. C
  4074. C     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
  4075. C     PROBLEMS.
  4076. C
  4077. 11    DR=Z(I)*TTHET
  4078. C
  4079. C     SPECULAR POINT DISTANCE
  4080. C
  4081.       D=DR*PHY+X(I)
  4082.       IF (IFAR.EQ.2) GO TO 13
  4083.       D=SQRT(D*D+(Y(I)-DR*PHX)**2)
  4084.       IF (IFAR.EQ.3) GO TO 13
  4085.       IF ((SCRWL-D).LT.0.) GO TO 12
  4086. C
  4087. C     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
  4088. C
  4089.       D=D+T2
  4090.       ZSCRN=T1*D*LOG(D/T2)
  4091.       ZSCRN=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
  4092.       ZRSIN=SQRT(1.-ZSCRN*ZSCRN*THZ*THZ)
  4093.       RRV=(ROZ+ZSCRN*ZRSIN)/(-ROZ+ZSCRN*ZRSIN)
  4094.       RRH=(ZSCRN*ROZ+ZRSIN)/(ZSCRN*ROZ-ZRSIN)
  4095.       GO TO 16
  4096. 12    IF (IFAR.EQ.4) GO TO 14
  4097.       IF (IFAR.EQ.5) D=DR*PHY+X(I)
  4098. 13    IF ((CL-D).LE.0.) GO TO 15
  4099. 14    RRV=RRV1
  4100.       RRH=RRH1
  4101.       GO TO 16
  4102. 15    RRV=RRV2
  4103.       RRH=RRH2
  4104.       ARG=ARG+DARG
  4105. 16    EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
  4106. C
  4107. C     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
  4108. C     FOR CLIFF AND GROUND SCREEN PROBLEMS
  4109. C
  4110.       TIX=EXA*CAB(I)
  4111.       TIY=EXA*SAB(I)
  4112.       TIZ=EXA*SALP(I)
  4113.       CDP=(TIX*PHX+TIY*PHY)*(RRH-RRV)
  4114.       CIX=CIX+TIX*RRV+CDP*PHX
  4115.       CIY=CIY+TIY*RRV+CDP*PHY
  4116.       CIZ=CIZ-TIZ*RRV
  4117. 17    CONTINUE
  4118.       IF (K.EQ.1) GO TO 19
  4119.       IF (IFAR.GE.2) GO TO 18
  4120. C
  4121. C     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
  4122. C
  4123.       CDP=(CIX*PHX+CIY*PHY)*(RRH-RRV)
  4124.       CIX=CCX+CIX*RRV+CDP*PHX
  4125.       CIY=CCY+CIY*RRV+CDP*PHY
  4126.       CIZ=CCZ-CIZ*RRV
  4127.       GO TO 19
  4128. 18    CIX=CIX+CCX
  4129.       CIY=CIY+CCY
  4130.       CIZ=CIZ+CCZ
  4131. 19    CONTINUE
  4132.       IF (M.GT.0) GO TO 21
  4133.       ETH=(CIX*THX+CIY*THY+CIZ*THZ)*CONST
  4134.       EPH=(CIX*PHX+CIY*PHY)*CONST
  4135.       RETURN
  4136. 20    CIX=(0.,0.)
  4137.       CIY=(0.,0.)
  4138.       CIZ=(0.,0.)
  4139. 21    ROZ=ROZS
  4140. C
  4141. C     ELECTRIC FIELD COMPONENTS
  4142. C
  4143.       RFL=-1.
  4144.       DO 25 IP=1,KSYMP
  4145.       RFL=-RFL
  4146.       RRZ=ROZ*RFL
  4147.       CALL FFLDS (ROX,ROY,RRZ,CUR(N+1),GX,GY,GZ)
  4148.       IF (IP.EQ.2) GO TO 22
  4149.       EX=GX
  4150.       EY=GY
  4151.       EZ=GZ
  4152.       GO TO 25
  4153. 22    IF (IPERF.NE.1) GO TO 23
  4154.       GX=-GX
  4155.       GY=-GY
  4156.       GZ=-GZ
  4157.       GO TO 24
  4158. 23    RRV=SQRT(1.-ZRATI*ZRATI*THZ*THZ)
  4159.       RRH=ZRATI*ROZ
  4160.       RRH=(RRH-RRV)/(RRH+RRV)
  4161.       RRV=ZRATI*RRV
  4162.       RRV=-(ROZ-RRV)/(ROZ+RRV)
  4163.       ETH=(GX*PHX+GY*PHY)*(RRH-RRV)
  4164.       GX=GX*RRV+ETH*PHX
  4165.       GY=GY*RRV+ETH*PHY
  4166.       GZ=GZ*RRV
  4167. 24    EX=EX+GX
  4168.       EY=EY+GY
  4169.       EZ=EZ-GZ
  4170. 25    CONTINUE
  4171.       EX=EX+CIX*CONST
  4172.       EY=EY+CIY*CONST
  4173.       EZ=EZ+CIZ*CONST
  4174.       ETH=EX*THX+EY*THY+EZ*THZ
  4175.       EPH=EX*PHX+EY*PHY
  4176.       RETURN
  4177.       END
  4178.       SUBROUTINE FFLDS (ROX,ROY,ROZ,SCUR,EX,EY,EZ)
  4179. C ***
  4180. C     DOUBLE PRECISION 6/4/85
  4181. C
  4182.       INCLUDE 'NEC2DPAR.INC'
  4183.       IMPLICIT REAL*8(A-H,O-Z)
  4184. C ***
  4185. C     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
  4186. C     SURFACE CURRENTS
  4187.       COMPLEX*16 CT,CONS,SCUR,EX,EY,EZ
  4188.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  4189.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  4190.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  4191.      &IPSYM
  4192.       DIMENSION XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2)
  4193.       EQUIVALENCE (XS,X), (YS,Y), (ZS,Z), (S,BI), (CONS,CONSX)
  4194.       DATA TPI/6.283185308D+0/,CONSX/0.,188.365/
  4195.       EX=(0.,0.)
  4196.       EY=(0.,0.)
  4197.       EZ=(0.,0.)
  4198.       I=LD+1
  4199.       DO 1 J=1,M
  4200.       I=I-1
  4201.       ARG=TPI*(ROX*XS(I)+ROY*YS(I)+ROZ*ZS(I))
  4202.       CT=DCMPLX(COS(ARG)*S(I),SIN(ARG)*S(I))
  4203.       K=3*J
  4204.       EX=EX+SCUR(K-2)*CT
  4205.       EY=EY+SCUR(K-1)*CT
  4206.       EZ=EZ+SCUR(K)*CT
  4207. 1     CONTINUE
  4208.       CT=ROX*EX+ROY*EY+ROZ*EZ
  4209.       EX=CONS*(CT*ROX-EX)
  4210.       EY=CONS*(CT*ROY-EY)
  4211.       EZ=CONS*(CT*ROZ-EZ)
  4212.       RETURN
  4213.       END
  4214.       SUBROUTINE GF (ZK,CO,SI)
  4215. C ***
  4216. C     DOUBLE PRECISION 6/4/85
  4217. C
  4218.       IMPLICIT REAL*8(A-H,O-Z)
  4219. C ***
  4220. C
  4221. C     GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
  4222. C
  4223.       COMMON /TMI/ ZPK,RKB2,IJ
  4224.       ZDK=ZK-ZPK
  4225.       RK=SQRT(RKB2+ZDK*ZDK)
  4226.       SI=SIN(RK)/RK
  4227.       IF (IJ) 1,2,1
  4228. 1     CO=COS(RK)/RK
  4229.       RETURN
  4230. 2     IF (RK.LT..2) GO TO 3
  4231.       CO=(COS(RK)-1.)/RK
  4232.       RETURN
  4233. 3     RKS=RK*RK
  4234.       CO=((-1.38888889D-3*RKS+4.16666667D-2)*RKS-.5)*RK
  4235.       RETURN
  4236.       END
  4237.       SUBROUTINE GFIL (IPRT)
  4238. C ***
  4239. C     DOUBLE PRECISION 6/4/85
  4240. C
  4241.       INCLUDE 'NEC2DPAR.INC'
  4242.       PARAMETER (IRESRV=4000000)
  4243.       IMPLICIT REAL*8(A-H,O-Z)
  4244. C ***
  4245. C
  4246. C     GFIL READS THE N.G.F. FILE
  4247. C
  4248.       COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI
  4249.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  4250.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  4251.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  4252.      &IPSYM
  4253.       COMMON /CMB/ CM(IRESRV)
  4254.       COMMON /ANGL/ SALP(MAXSEG)
  4255.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  4256.      1IPERF,T1,T2
  4257.       COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
  4258.      1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
  4259.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  4260.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  4261.       COMMON /SMAT/ SSX(16,16)
  4262.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  4263.       COMMON/SAVE/IP(2*MAXSEG),KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,
  4264.      &FMHZ
  4265. C
  4266. C*** ERROR CORRECTED 11/20/89 *******************************
  4267.       DIMENSION T2X(1),T2Y(1),T2Z(1)
  4268.       EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
  4269. C***
  4270.       DATA IGFL/20/
  4271.       OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='OLD')
  4272.       REWIND IGFL
  4273.       READ (IGFL) N1,NP,M1,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,SIG
  4274.      1,SCRWLT,SCRWRT,NLODF,KCOM
  4275.       N=N1
  4276.       M=M1
  4277.       N2=N1+1
  4278.       M2=M1+1
  4279.       IF (N1.EQ.0) GO TO 2
  4280. C     READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS
  4281.       READ (IGFL) (X(I),I=1,N1),(Y(I),I=1,N1),(Z(I),I=1,N1)
  4282.       READ (IGFL) (SI(I),I=1,N1),(BI(I),I=1,N1),(ALP(I),I=1,N1)
  4283.       READ (IGFL) (BET(I),I=1,N1),(SALP(I),I=1,N1)
  4284.       READ (IGFL) (ICON1(I),I=1,N1),(ICON2(I),I=1,N1)
  4285.       READ (IGFL) (ITAG(I),I=1,N1)
  4286.       IF (NLODF.NE.0) READ (IGFL) (ZARRAY(I),I=1,N1)
  4287.       DO 1 I=1,N1
  4288.       XI=X(I)*WLAM
  4289.       YI=Y(I)*WLAM
  4290.       ZI=Z(I)*WLAM
  4291.       DX=SI(I)*.5*WLAM
  4292.       X(I)=XI-ALP(I)*DX
  4293.       Y(I)=YI-BET(I)*DX
  4294.       Z(I)=ZI-SALP(I)*DX
  4295.       SI(I)=XI+ALP(I)*DX
  4296.       ALP(I)=YI+BET(I)*DX
  4297.       BET(I)=ZI+SALP(I)*DX
  4298.       BI(I)=BI(I)*WLAM
  4299. 1     CONTINUE
  4300. 2     IF (M1.EQ.0) GO TO 4
  4301.       J=LD-M1+1
  4302. C     READ PATCH DATA AND CONVERT TO METERS
  4303.       READ (IGFL) (X(I),I=J,LD),(Y(I),I=J,LD),(Z(I),I=J,LD)
  4304.       READ (IGFL) (SI(I),I=J,LD),(BI(I),I=J,LD),(ALP(I),I=J,LD)
  4305.       READ (IGFL) (BET(I),I=J,LD),(SALP(I),I=J,LD)
  4306. C*** ERROR CORRECTED 11/20/89 *******************************
  4307.       READ (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD)
  4308.       READ (IGFL) (T2Z(I),I=J,LD)
  4309. C      READ (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD)
  4310. C      READ (IGFL) (ITAG(I),I=J,LD)
  4311. C
  4312.       DX=WLAM*WLAM
  4313.       DO 3 I=J,LD
  4314.       X(I)=X(I)*WLAM
  4315.       Y(I)=Y(I)*WLAM
  4316.       Z(I)=Z(I)*WLAM
  4317. 3     BI(I)=BI(I)*DX
  4318. 4     READ (IGFL) ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT
  4319.       IF (IPERF.EQ.2) READ (IGFL) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA,
  4320.      1NYA
  4321.       NEQ=N1+2*M1
  4322.       NPEQ=NP+2*MP
  4323.       NOP=NEQ/NPEQ
  4324.       IF (NOP.GT.1) READ (IGFL) ((SSX(I,J),I=1,NOP),J=1,NOP)
  4325.       READ (IGFL) (IP(I),I=1,NEQ),COM
  4326. C     READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE
  4327.       IF (ICASE.GT.2) GO TO 5
  4328.       IOUT=NEQ*NPEQ
  4329.       READ (IGFL) (CM(I),I=1,IOUT)
  4330.       GO TO 10
  4331. 5     REWIND 13
  4332.       IF (ICASE.NE.4) GO TO 7
  4333.       IOUT=NPEQ*NPEQ
  4334.       DO 6 K=1,NOP
  4335.       READ (IGFL) (CM(J),J=1,IOUT)
  4336. 6     WRITE (13) (CM(J),J=1,IOUT)
  4337.       GO TO 9
  4338. 7     IOUT=NPSYM*NPEQ*2
  4339.       NBL2=2*NBLSYM
  4340.       DO 8 IOP=1,NOP
  4341.       DO 8 I=1,NBL2
  4342.       CALL BLCKIN (CM,IGFL,1,IOUT,1,206)
  4343. 8     CALL BLCKOT (CM,13,1,IOUT,1,205)
  4344. 9     REWIND 13
  4345. 10    REWIND IGFL
  4346. C     WRITE(3,N) G.F. HEADING
  4347.       WRITE(3,16)
  4348.       WRITE(3,14)
  4349.       WRITE(3,14)
  4350.       WRITE(3,17)
  4351.       WRITE(3,18)  N1,M1
  4352.       IF (NOP.GT.1) WRITE(3,19)  NOP
  4353.       WRITE(3,20)  IMAT,ICASE
  4354.       IF (ICASE.LT.3) GO TO 11
  4355.       NBL2=NEQ*NPEQ
  4356.       WRITE(3,21)  NBL2
  4357. 11    WRITE(3,22)  FMHZ
  4358.       IF (KSYMP.EQ.2.AND.IPERF.EQ.1) WRITE(3,23)
  4359.       IF (KSYMP.EQ.2.AND.IPERF.EQ.0) WRITE(3,27)
  4360.       IF (KSYMP.EQ.2.AND.IPERF.EQ.2) WRITE(3,28)
  4361.       IF (KSYMP.EQ.2.AND.IPERF.NE.1) WRITE(3,24)  EPSR,SIG
  4362.       WRITE(3,17)
  4363.       DO 12 J=1,KCOM
  4364. 12    WRITE(3,15)  (COM(I,J),I=1,19)
  4365.       WRITE(3,17)
  4366.       WRITE(3,14)
  4367.       WRITE(3,14)
  4368.       WRITE(3,16)
  4369.       IF (IPRT.EQ.0) RETURN
  4370.       WRITE(3,25)
  4371.       DO 13 I=1,N1
  4372. 13    WRITE(3,26)  I,X(I),Y(I),Z(I),SI(I),ALP(I),BET(I)
  4373.       RETURN
  4374. C
  4375. 14    FORMAT (5X,50H**************************************************,
  4376.      &34H**********************************)
  4377. 15    FORMAT (5X,3H** ,19A4,3H **)
  4378. 16    FORMAT (////)
  4379. 17    FORMAT (5X,2H**,80X,2H**)
  4380. 18    FORMAT (5X,29H** NUMERICAL GREEN'S FUNCTION,53X,2H**,/,5X,17H** NO
  4381.      1. SEGMENTS =,I4,10X,13HNO. PATCHES =,I4,34X,2H**)
  4382. 19    FORMAT (5X,27H** NO. SYMMETRIC SECTIONS =,I4,51X,2H**)
  4383. 20    FORMAT (5X,34H** N.G.F. MATRIX -  CORE STORAGE =,I7,23H COMPLEX NU
  4384.      1MBERS,  CASE,I2,16X,2H**)
  4385. 21    FORMAT (5X,2H**,19X,13HMATRIX SIZE =,I7,16H COMPLEX NUMBERS,25X,2H
  4386.      1**)
  4387. 22    FORMAT (5X,14H** FREQUENCY =,1P,E12.5,5H MHZ.,51X,2H**)
  4388. 23    FORMAT (5X,17H** PERFECT GROUND,65X,2H**)
  4389. 24    FORMAT (5X,44H** GROUND PARAMETERS - DIELECTRIC CONSTANT =,1P,
  4390.      1E12.5,26X,2H**,/,5X,2H**,21X,14HCONDUCTIVITY =,E12.5,8H MHOS/M.,
  4391.      225X,2H**)
  4392. 25    FORMAT (39X,31HNUMERICAL GREEN'S FUNCTION DATA,/,41X,27HCOORDINATE
  4393.      1S OF SEGMENT ENDS,/,51X,8H(METERS),/,5X,4HSEG.,11X,19H- - - END ON
  4394.      2E - - -,26X,19H- - - END TWO - - -,/,6X,3HNO.,6X,1HX,14X,1HY,14X,1
  4395.      3HZ,14X,1HX,14X,1HY,14X,1HZ)
  4396. 26    FORMAT (1X,I7,1P,6E15.6)
  4397. 27    FORMAT (5X,55H** FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMAT
  4398.      1ION,27X,2H**)
  4399. 28    FORMAT (5X,38H** FINITE GROUND.  SOMMERFELD SOLUTION,44X,2H**)
  4400.       END
  4401.       SUBROUTINE GFLD (RHO,PHI,RZ,ETH,EPI,ERD,UX,KSYMP)
  4402. C ***
  4403. C     DOUBLE PRECISION 6/4/85
  4404. C
  4405.       INCLUDE 'NEC2DPAR.INC'
  4406.       IMPLICIT REAL*8(A-H,O-Z)
  4407. C ***
  4408. C
  4409. C     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
  4410. C
  4411.       COMPLEX*16 CUR,EPI,CIX,CIY,CIZ,EXA,XX1,XX2,U,U2,ERV,EZV,ERH,EPH
  4412.       COMPLEX*16 EZH,EX,EY,ETH,UX,ERD
  4413.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  4414.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  4415.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  4416.      &IPSYM
  4417.       COMMON /ANGL/ SALP(MAXSEG)
  4418.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  4419.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  4420.       COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH
  4421.       DIMENSION CAB(1), SAB(1)
  4422.       EQUIVALENCE (CAB(1),ALP(1)), (SAB(1),BET(1))
  4423.       DATA PI,TP/3.141592654D+0,6.283185308D+0/
  4424.       R=SQRT(RHO*RHO+RZ*RZ)
  4425.       IF (KSYMP.EQ.1) GO TO 1
  4426.       IF (ABS(UX).GT..5) GO TO 1
  4427.       IF (R.GT.1.E5) GO TO 1
  4428.       GO TO 4
  4429. C
  4430. C     COMPUTATION OF SPACE WAVE ONLY
  4431. C
  4432. 1     IF (RZ.LT.1.D-20) GO TO 2
  4433.       THET=ATAN(RHO/RZ)
  4434.       GO TO 3
  4435. 2     THET=PI*.5
  4436. 3     CALL FFLD (THET,PHI,ETH,EPI)
  4437.       ARG=-TP*R
  4438.       EXA=DCMPLX(COS(ARG),SIN(ARG))/R
  4439.       ETH=ETH*EXA
  4440.       EPI=EPI*EXA
  4441.       ERD=(0.,0.)
  4442.       RETURN
  4443. C
  4444. C     COMPUTATION OF SPACE AND GROUND WAVES.
  4445. C
  4446. 4     U=UX
  4447.       U2=U*U
  4448.       PHX=-SIN(PHI)
  4449.       PHY=COS(PHI)
  4450.       RX=RHO*PHY
  4451.       RY=-RHO*PHX
  4452.       CIX=(0.,0.)
  4453.       CIY=(0.,0.)
  4454.       CIZ=(0.,0.)
  4455. C
  4456. C     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS
  4457. C
  4458.       DO 17 I=1,N
  4459.       DX=CAB(I)
  4460.       DY=SAB(I)
  4461.       DZ=SALP(I)
  4462.       RIX=RX-X(I)
  4463.       RIY=RY-Y(I)
  4464.       RHS=RIX*RIX+RIY*RIY
  4465.       RHP=SQRT(RHS)
  4466.       IF (RHP.LT.1.D-6) GO TO 5
  4467.       RHX=RIX/RHP
  4468.       RHY=RIY/RHP
  4469.       GO TO 6
  4470. 5     RHX=1.
  4471.       RHY=0.
  4472. 6     CALP=1.-DZ*DZ
  4473.       IF (CALP.LT.1.D-6) GO TO 7
  4474.       CALP=SQRT(CALP)
  4475.       CBET=DX/CALP
  4476.       SBET=DY/CALP
  4477.       CPH=RHX*CBET+RHY*SBET
  4478.       SPH=RHY*CBET-RHX*SBET
  4479.       GO TO 8
  4480. 7     CPH=RHX
  4481.       SPH=RHY
  4482. 8     EL=PI*SI(I)
  4483.       RFL=-1.
  4484. C
  4485. C     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
  4486. C     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS
  4487. C
  4488.       DO 16 K=1,2
  4489.       RFL=-RFL
  4490.       RIZ=RZ-Z(I)*RFL
  4491.       RXYZ=SQRT(RIX*RIX+RIY*RIY+RIZ*RIZ)
  4492.       RNX=RIX/RXYZ
  4493.       RNY=RIY/RXYZ
  4494.       RNZ=RIZ/RXYZ
  4495.       OMEGA=-(RNX*DX+RNY*DY+RNZ*DZ*RFL)
  4496.       SILL=OMEGA*EL
  4497.       TOP=EL+SILL
  4498.       BOT=EL-SILL
  4499.       IF (ABS(OMEGA).LT.1.D-7) GO TO 9
  4500.       A=2.*SIN(SILL)/OMEGA
  4501.       GO TO 10
  4502. 9     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
  4503. 10    IF (ABS(TOP).LT.1.D-7) GO TO 11
  4504.       TOO=SIN(TOP)/TOP
  4505.       GO TO 12
  4506. 11    TOO=1.-TOP*TOP/6.
  4507. 12    IF (ABS(BOT).LT.1.D-7) GO TO 13
  4508.       BOO=SIN(BOT)/BOT
  4509.       GO TO 14
  4510. 13    BOO=1.-BOT*BOT/6.
  4511. 14    B=EL*(BOO-TOO)
  4512.       C=EL*(BOO+TOO)
  4513.       RR=A*AIR(I)+B*BII(I)+C*CIR(I)
  4514.       RI=A*AII(I)-B*BIR(I)+C*CII(I)
  4515.       ARG=TP*(X(I)*RNX+Y(I)*RNY+Z(I)*RNZ*RFL)
  4516.       EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)/TP
  4517.       IF (K.EQ.2) GO TO 15
  4518.       XX1=EXA
  4519.       R1=RXYZ
  4520.       ZMH=RIZ
  4521.       GO TO 16
  4522. 15    XX2=EXA
  4523.       R2=RXYZ
  4524.       ZPH=RIZ
  4525. 16    CONTINUE
  4526. C
  4527. C     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND
  4528. C     WAVE.
  4529. C
  4530.       CALL GWAVE (ERV,EZV,ERH,EZH,EPH)
  4531.       ERH=ERH*CPH*CALP+ERV*DZ
  4532.       EPH=EPH*SPH*CALP
  4533.       EZH=EZH*CPH*CALP+EZV*DZ
  4534.       EX=ERH*RHX-EPH*RHY
  4535.       EY=ERH*RHY+EPH*RHX
  4536.       CIX=CIX+EX
  4537.       CIY=CIY+EY
  4538. 17    CIZ=CIZ+EZH
  4539.       ARG=-TP*R
  4540.       EXA=DCMPLX(COS(ARG),SIN(ARG))
  4541.       CIX=CIX*EXA
  4542.       CIY=CIY*EXA
  4543.       CIZ=CIZ*EXA
  4544.       RNX=RX/R
  4545.       RNY=RY/R
  4546.       RNZ=RZ/R
  4547.       THX=RNZ*PHY
  4548.       THY=-RNZ*PHX
  4549.       THZ=-RHO/R
  4550.       ETH=CIX*THX+CIY*THY+CIZ*THZ
  4551.       EPI=CIX*PHX+CIY*PHY
  4552.       ERD=CIX*RNX+CIY*RNY+CIZ*RNZ
  4553.       RETURN
  4554.       END
  4555.       SUBROUTINE GFOUT
  4556. C ***
  4557. C     DOUBLE PRECISION 6/4/85
  4558. C
  4559.       INCLUDE 'NEC2DPAR.INC'
  4560.       PARAMETER (IRESRV=4000000)
  4561.       IMPLICIT REAL*8(A-H,O-Z)
  4562. C ***
  4563. C
  4564. C     WRITE N.G.F. FILE
  4565. C
  4566.       COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI
  4567.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  4568.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  4569.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  4570.      &IPSYM
  4571.       COMMON /CMB/ CM(IRESRV)
  4572.       COMMON /ANGL/ SALP(MAXSEG)
  4573.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  4574.      1IPERF,T1,T2
  4575.       COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
  4576.      1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
  4577.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  4578.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  4579.       COMMON /SMAT/ SSX(16,16)
  4580.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  4581.       COMMON/SAVE/IP(2*MAXSEG),KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,
  4582.      &FMHZ
  4583. C
  4584. C*** ERROR CORRECTED 11/20/89 *******************************
  4585.       DIMENSION T2X(1),T2Y(1),T2Z(1)
  4586.       EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
  4587. C***
  4588.       DATA IGFL/20/
  4589.       OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='NEW')
  4590.       NEQ=N+2*M
  4591.       NPEQ=NP+2*MP
  4592.       NOP=NEQ/NPEQ
  4593.       WRITE (IGFL) N,NP,M,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,
  4594.      1SIG,SCRWLT,SCRWRT,NLOAD,KCOM
  4595.       IF (N.EQ.0) GO TO 1
  4596.       WRITE (IGFL) (X(I),I=1,N),(Y(I),I=1,N),(Z(I),I=1,N)
  4597.       WRITE (IGFL) (SI(I),I=1,N),(BI(I),I=1,N),(ALP(I),I=1,N)
  4598.       WRITE (IGFL) (BET(I),I=1,N),(SALP(I),I=1,N)
  4599.       WRITE (IGFL) (ICON1(I),I=1,N),(ICON2(I),I=1,N)
  4600.       WRITE (IGFL) (ITAG(I),I=1,N)
  4601.       IF (NLOAD.GT.0) WRITE (IGFL) (ZARRAY(I),I=1,N)
  4602. 1     IF (M.EQ.0) GO TO 2
  4603.       J=LD-M+1
  4604.       WRITE (IGFL) (X(I),I=J,LD),(Y(I),I=J,LD),(Z(I),I=J,LD)
  4605.       WRITE (IGFL) (SI(I),I=J,LD),(BI(I),I=J,LD),(ALP(I),I=J,LD)
  4606.       WRITE (IGFL) (BET(I),I=J,LD),(SALP(I),I=J,LD)
  4607. C
  4608. C*** ERROR CORRECTED 11/20/89 *******************************
  4609.                                                              
  4610.       WRITE (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD)
  4611.       WRITE (IGFL) (T2Z(I),I=J,LD)
  4612. C      WRITE (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD)
  4613. C      WRITE (IGFL) (ITAG(I),I=J,LD)
  4614. C
  4615. 2     WRITE (IGFL) ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT
  4616.       IF (IPERF.EQ.2) WRITE (IGFL) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA
  4617.      1,NYA
  4618.       IF (NOP.GT.1) WRITE (IGFL) ((SSX(I,J),I=1,NOP),J=1,NOP)
  4619.       WRITE (IGFL) (IP(I),I=1,NEQ),COM
  4620.       IF (ICASE.GT.2) GO TO 3
  4621.       IOUT=NEQ*NPEQ
  4622.       WRITE (IGFL) (CM(I),I=1,IOUT)
  4623.       GO TO 12
  4624. 3     IF (ICASE.NE.4) GO TO 5
  4625.       REWIND 13
  4626.       I=NPEQ*NPEQ
  4627.       DO 4 K=1,NOP
  4628.       READ (13) (CM(J),J=1,I)
  4629. 4     WRITE (IGFL) (CM(J),J=1,I)
  4630.       REWIND 13
  4631.       GO TO 12
  4632. 5     REWIND 13
  4633.       REWIND 14
  4634.       IF (ICASE.EQ.5) GO TO 8
  4635.       IOUT=NPBLK*NEQ*2
  4636.       DO 6 I=1,NBLOKS
  4637.       CALL BLCKIN (CM,13,1,IOUT,1,201)
  4638. 6     CALL BLCKOT (CM,IGFL,1,IOUT,1,202)
  4639.       DO 7 I=1,NBLOKS
  4640.       CALL BLCKIN (CM,14,1,IOUT,1,203)
  4641. 7     CALL BLCKOT (CM,IGFL,1,IOUT,1,204)
  4642.       GO TO 12
  4643. 8     IOUT=NPSYM*NPEQ*2
  4644.       DO 11 IOP=1,NOP
  4645.       DO 9 I=1,NBLSYM
  4646.       CALL BLCKIN (CM,13,1,IOUT,1,205)
  4647. 9     CALL BLCKOT (CM,IGFL,1,IOUT,1,206)
  4648.       DO 10 I=1,NBLSYM
  4649.       CALL BLCKIN (CM,14,1,IOUT,1,207)
  4650. 10    CALL BLCKOT (CM,IGFL,1,IOUT,1,208)
  4651. 11    CONTINUE
  4652.       REWIND 13
  4653.       REWIND 14
  4654. 12    REWIND IGFL
  4655.       WRITE(3,13)  IGFL,IMAT
  4656.       RETURN
  4657. C
  4658. 13    FORMAT (///,44H ****NUMERICAL GREEN'S FUNCTION FILE ON TAPE,I3,5H
  4659.      1****,/,5X,16HMATRIX STORAGE -,I7,16H COMPLEX NUMBERS,///)
  4660.       END
  4661.       SUBROUTINE GH (ZK,HR,HI)
  4662. C ***
  4663. C     DOUBLE PRECISION 6/4/85
  4664. C
  4665.       IMPLICIT REAL*8(A-H,O-Z)
  4666. C ***
  4667. C     INTEGRAND FOR H FIELD OF A WIRE
  4668.       COMMON /TMH/ ZPK,RHKS
  4669.       RS=ZK-ZPK
  4670.       RS=RHKS+RS*RS
  4671.       R=SQRT(RS)
  4672.       CKR=COS(R)
  4673.       SKR=SIN(R)
  4674.       RR2=1./RS
  4675.       RR3=RR2/R
  4676.       HR=SKR*RR2+CKR*RR3
  4677.       HI=CKR*RR2-SKR*RR3
  4678.       RETURN
  4679.       END
  4680.       SUBROUTINE GWAVE (ERV,EZV,ERH,EZH,EPH)
  4681. C ***
  4682. C     DOUBLE PRECISION 6/4/85
  4683. C
  4684.       IMPLICIT REAL*8(A-H,O-Z)
  4685. C ***
  4686. C
  4687. C     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A
  4688. C     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON
  4689. C     (PROC. IRE, SEPT., 1937, PP.1203,1236.)
  4690. C
  4691.       COMPLEX*16 FJ,TPJ,U2,U,RK1,RK2,T1,T2,T3,T4,P1,RV,OMR,W,F,Q1,RH,V,G
  4692.      1,XR1,XR2,X1,X2,X3,X4,X5,X6,X7,EZV,ERV,EZH,ERH,EPH,XX1,XX2,ECON,
  4693.      2FBAR
  4694.       COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH
  4695.       DIMENSION FJX(2), TPJX(2), ECONX(2)
  4696.       EQUIVALENCE (FJ,FJX), (TPJ,TPJX), (ECON,ECONX)
  4697.       DATA PI/3.141592654D+0/,FJX/0.,1./,TPJX/0.,6.283185308D+0/
  4698.       DATA ECONX/0.,-188.367/
  4699.       SPPP=ZMH/R1
  4700.       SPPP2=SPPP*SPPP
  4701.       CPPP2=1.-SPPP2
  4702.       IF (CPPP2.LT.1.D-20) CPPP2=1.D-20
  4703.       CPPP=SQRT(CPPP2)
  4704.       SPP=ZPH/R2
  4705.       SPP2=SPP*SPP
  4706.       CPP2=1.-SPP2
  4707.       IF (CPP2.LT.1.D-20) CPP2=1.D-20
  4708.       CPP=SQRT(CPP2)
  4709.       RK1=-TPJ*R1
  4710.       RK2=-TPJ*R2
  4711.       T1=1.-U2*CPP2
  4712.       T2=SQRT(T1)
  4713.       T3=(1.-1./RK1)/RK1
  4714.       T4=(1.-1./RK2)/RK2
  4715.       P1=RK2*U2*T1/(2.*CPP2)
  4716.       RV=(SPP-U*T2)/(SPP+U*T2)
  4717.       OMR=1.-RV
  4718.       W=1./OMR
  4719.       W=(4.,0.)*P1*W*W
  4720.       F=FBAR(W)
  4721.       Q1=RK2*T1/(2.*U2*CPP2)
  4722.       RH=(T2-U*SPP)/(T2+U*SPP)
  4723.       V=1./(1.+RH)
  4724.       V=(4.,0.)*Q1*V*V
  4725.       G=FBAR(V)
  4726.       XR1=XX1/R1
  4727.       XR2=XX2/R2
  4728.       X1=CPPP2*XR1
  4729.       X2=RV*CPP2*XR2
  4730.       X3=OMR*CPP2*F*XR2
  4731.       X4=U*T2*SPP*2.*XR2/RK2
  4732.       X5=XR1*T3*(1.-3.*SPPP2)
  4733.       X6=XR2*T4*(1.-3.*SPP2)
  4734.       EZV=(X1+X2+X3-X4-X5-X6)*ECON
  4735.       X1=SPPP*CPPP*XR1
  4736.       X2=RV*SPP*CPP*XR2
  4737.       X3=CPP*OMR*U*T2*F*XR2
  4738.       X4=SPP*CPP*OMR*XR2/RK2
  4739.       X5=3.*SPPP*CPPP*T3*XR1
  4740.       X6=CPP*U*T2*OMR*XR2/RK2*.5
  4741.       X7=3.*SPP*CPP*T4*XR2
  4742.       ERV=-(X1+X2-X3+X4-X5+X6-X7)*ECON
  4743.       EZH=-(X1-X2+X3-X4-X5-X6+X7)*ECON
  4744.       X1=SPPP2*XR1
  4745.       X2=RV*SPP2*XR2
  4746.       X4=U2*T1*OMR*F*XR2
  4747.       X5=T3*(1.-3.*CPPP2)*XR1
  4748.       X6=T4*(1.-3.*CPP2)*(1.-U2*(1.+RV)-U2*OMR*F)*XR2
  4749.       X7=U2*CPP2*OMR*(1.-1./RK2)*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2
  4750.       ERH=(X1-X2-X4-X5+X6+X7)*ECON
  4751.       X1=XR1
  4752.       X2=RH*XR2
  4753.       X3=(RH+1.)*G*XR2
  4754.       X4=T3*XR1
  4755.       X5=T4*(1.-U2*(1.+RV)-U2*OMR*F)*XR2
  4756.       X6=.5*U2*OMR*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2/RK2
  4757.       EPH=-(X1-X2+X3-X4+X5+X6)*ECON
  4758.       RETURN
  4759.       END
  4760.       SUBROUTINE GX (ZZ,RH,XK,GZ,GZP)
  4761. C ***
  4762. C     DOUBLE PRECISION 6/4/85
  4763. C
  4764.       IMPLICIT REAL*8(A-H,O-Z)
  4765. C ***
  4766. C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
  4767.       COMPLEX*16 GZ,GZP
  4768.       R2=ZZ*ZZ+RH*RH
  4769.       R=SQRT(R2)
  4770.       RK=XK*R
  4771.       GZ=DCMPLX(COS(RK),-SIN(RK))/R
  4772.       GZP=-DCMPLX(1.D+0,RK)*GZ/R2
  4773.       RETURN
  4774.       END
  4775.       SUBROUTINE GXX (ZZ,RH,A,A2,XK,IRA,G1,G1P,G2,G2P,G3,GZP)
  4776. C ***
  4777. C     DOUBLE PRECISION 6/4/85
  4778. C
  4779.       IMPLICIT REAL*8(A-H,O-Z)
  4780. C ***
  4781. C     SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.
  4782.       COMPLEX*16 GZ,C1,C2,C3,G1,G1P,G2,G2P,G3,GZP
  4783.       R2=ZZ*ZZ+RH*RH
  4784.       R=SQRT(R2)
  4785.       R4=R2*R2
  4786.       RK=XK*R
  4787.       RK2=RK*RK
  4788.       RH2=RH*RH
  4789.       T1=.25*A2*RH2/R4
  4790.       T2=.5*A2/R2
  4791.       C1=DCMPLX(1.D+0,RK)
  4792.       C2=3.*C1-RK2
  4793.       C3=DCMPLX(6.D+0,RK)*RK2-15.*C1
  4794.       GZ=DCMPLX(COS(RK),-SIN(RK))/R
  4795.       G2=GZ*(1.+T1*C2)
  4796.       G1=G2-T2*C1*GZ
  4797.       GZ=GZ/R2
  4798.       G2P=GZ*(T1*C3-C1)
  4799.       GZP=T2*C2*GZ
  4800.       G3=G2P+GZP
  4801.       G1P=G3*ZZ
  4802.       IF (IRA.EQ.1) GO TO 2
  4803.       G3=(G3+GZP)*RH
  4804.       GZP=-ZZ*C1*GZ
  4805.       IF (RH.GT.1.D-10) GO TO 1
  4806.       G2=0.
  4807.       G2P=0.
  4808.       RETURN
  4809. 1     G2=G2/RH
  4810.       G2P=G2P*ZZ/RH
  4811.       RETURN
  4812. 2     T2=.5*A
  4813.       G2=-T2*C1*GZ
  4814.       G2P=T2*GZ*C2/R2
  4815.       G3=RH2*G2P-A*GZ*C1
  4816.       G2P=G2P*ZZ
  4817.       GZP=-ZZ*C1*GZ
  4818.       RETURN
  4819.       END
  4820.       SUBROUTINE HELIX(S,HL,A1,B1,A2,B2,RAD,NS,ITG)
  4821. C ***
  4822. C     DOUBLE PRECISION 6/4/85
  4823. C
  4824.       INCLUDE 'NEC2DPAR.INC'
  4825.       IMPLICIT REAL*8(A-H,O-Z)
  4826. C ***
  4827. C     SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
  4828. C     SEGMENTS
  4829.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  4830.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  4831.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  4832.      &IPSYM
  4833.       DIMENSION X2(1),Y2(1),Z2(1)
  4834.       EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1))
  4835.       DATA PI/3.1415926D+0/
  4836.       IST=N+1
  4837.       N=N+NS
  4838.       NP=N
  4839.       MP=M
  4840.       IPSYM=0
  4841.       IF(NS.LT.1) RETURN
  4842.       TURNS=ABS(HL/S)
  4843.       ZINC=ABS(HL/NS)
  4844.       Z(IST)=0.
  4845.       DO 25 I=IST,N
  4846.       BI(I)=RAD
  4847.       ITAG(I)=ITG
  4848.       IF(I.NE.IST) Z(I)=Z(I-1)+ZINC
  4849.       Z2(I)=Z(I)+ZINC
  4850.       IF(A2.NE.A1) GO TO 10
  4851.       IF(B1.EQ.0) B1=A1
  4852.       X(I)=A1*COS(2.*PI*Z(I)/S)
  4853.       Y(I)=B1*SIN(2.*PI*Z(I)/S)
  4854.       X2(I)=A1*COS(2.*PI*Z2(I)/S)
  4855.       Y2(I)=B1*SIN(2.*PI*Z2(I)/S)
  4856.       GO TO 20
  4857. 10    IF(B2.EQ.0) B2=A2
  4858.       X(I)=(A1+(A2-A1)*Z(I)/ABS(HL))*COS(2.*PI*Z(I)/S)
  4859.       Y(I)=(B1+(B2-B1)*Z(I)/ABS(HL))*SIN(2.*PI*Z(I)/S)
  4860.       X2(I)=(A1+(A2-A1)*Z2(I)/ABS(HL))*COS(2.*PI*Z2(I)/S)
  4861.       Y2(I)=(B1+(B2-B1)*Z2(I)/ABS(HL))*SIN(2.*PI*Z2(I)/S)
  4862. 20    IF(HL.GT.0) GO TO 25
  4863.       COPY=X(I)
  4864.       X(I)=Y(I)
  4865.       Y(I)=COPY
  4866.       COPY=X2(I)
  4867.       X2(I)=Y2(I)
  4868.       Y2(I)=COPY
  4869. 25    CONTINUE
  4870.       IF(A2.EQ.A1) GO TO 21
  4871.       SANGLE=ATAN(A2/(ABS(HL)+(ABS(HL)*A1)/(A2-A1)))
  4872.       WRITE(3,104)  SANGLE
  4873. 104   FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
  4874.       RETURN
  4875. 21    IF(A1.NE.B1) GO TO 30
  4876.       HDIA=2.*A1
  4877.       TURN=HDIA*PI
  4878.       PITCH=ATAN(S/(PI*HDIA))
  4879.       TURN=TURN/COS(PITCH)
  4880.       PITCH=180.*PITCH/PI
  4881.       GO TO 40
  4882. 30    IF(A1.LT.B1) GO TO 34
  4883.       HMAJ=2.*A1
  4884.       HMIN=2.*B1
  4885.       GO TO 35
  4886. 34    HMAJ=2.*B1
  4887.       HMIN=2.*A1
  4888. 35    HDIA=SQRT((HMAJ**2+HMIN**2)/2*HMAJ)
  4889.       TURN=2.*PI*HDIA
  4890.       PITCH=(180./PI)*ATAN(S/(PI*HDIA))
  4891. 40    WRITE(3,105) PITCH,TURN
  4892. 105   FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,'THE LENGTH OF WIRE/TURN I
  4893.      1S',F10.4)
  4894.       RETURN
  4895.       END
  4896.       SUBROUTINE HFK (EL1,EL2,RHK,ZPKX,SGR,SGI)
  4897. C ***
  4898. C     DOUBLE PRECISION 6/4/85
  4899. C
  4900.       IMPLICIT REAL*8(A-H,O-Z)
  4901. C ***
  4902. C     HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY
  4903. C     NUMERICAL INTEGRATION
  4904.       COMMON /TMH/ ZPK,RHKS
  4905.       DATA NX,NM,NTS,RX/1,65536,4,1.D-4/
  4906.       ZPK=ZPKX
  4907.       RHKS=RHK*RHK
  4908.       Z=EL1
  4909.       ZE=EL2
  4910.       S=ZE-Z
  4911.       EP=S/(10.*NM)
  4912.       ZEND=ZE-EP
  4913.       SGR=0.0
  4914.       SGI=0.0
  4915.       NS=NX
  4916.       NT=0
  4917.       CALL GH (Z,G1R,G1I)
  4918. 1     DZ=S/NS
  4919.       ZP=Z+DZ
  4920.       IF (ZP-ZE) 3,3,2
  4921. 2     DZ=ZE-Z
  4922.       IF (ABS(DZ)-EP) 17,17,3
  4923. 3     DZOT=DZ*.5
  4924.       ZP=Z+DZOT
  4925.       CALL GH (ZP,G3R,G3I)
  4926.       ZP=Z+DZ
  4927.       CALL GH (ZP,G5R,G5I)
  4928. 4     T00R=(G1R+G5R)*DZOT
  4929.       T00I=(G1I+G5I)*DZOT
  4930.       T01R=(T00R+DZ*G3R)*0.5
  4931.       T01I=(T00I+DZ*G3I)*0.5
  4932.       T10R=(4.0*T01R-T00R)/3.0
  4933.       T10I=(4.0*T01I-T00I)/3.0
  4934.       CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.)
  4935.       IF (TE1I-RX) 5,5,6
  4936. 5     IF (TE1R-RX) 8,8,6
  4937. 6     ZP=Z+DZ*0.25
  4938.       CALL GH (ZP,G2R,G2I)
  4939.       ZP=Z+DZ*0.75
  4940.       CALL GH (ZP,G4R,G4I)
  4941.       T02R=(T01R+DZOT*(G2R+G4R))*0.5
  4942.       T02I=(T01I+DZOT*(G2I+G4I))*0.5
  4943.       T11R=(4.0*T02R-T01R)/3.0
  4944.       T11I=(4.0*T02I-T01I)/3.0
  4945.       T20R=(16.0*T11R-T10R)/15.0
  4946.       T20I=(16.0*T11I-T10I)/15.0
  4947.       CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.)
  4948.       IF (TE2I-RX) 7,7,14
  4949. 7     IF (TE2R-RX) 9,9,14
  4950. 8     SGR=SGR+T10R
  4951.       SGI=SGI+T10I
  4952.       NT=NT+2
  4953.       GO TO 10
  4954. 9     SGR=SGR+T20R
  4955.       SGI=SGI+T20I
  4956.       NT=NT+1
  4957. 10    Z=Z+DZ
  4958.       IF (Z-ZEND) 11,17,17
  4959. 11    G1R=G5R
  4960.       G1I=G5I
  4961.       IF (NT-NTS) 1,12,12
  4962. 12    IF (NS-NX) 1,1,13
  4963. 13    NS=NS/2
  4964.       NT=1
  4965.       GO TO 1
  4966. 14    NT=0
  4967.       IF (NS-NM) 16,15,15
  4968. 15    WRITE(3,18)  Z
  4969.       GO TO 9
  4970. 16    NS=NS*2
  4971.       DZ=S/NS
  4972.       DZOT=DZ*0.5
  4973.       G5R=G3R
  4974.       G5I=G3I
  4975.       G3R=G2R
  4976.       G3I=G2I
  4977.       GO TO 4
  4978. 17    CONTINUE
  4979.       SGR=SGR*RHK*.5
  4980.       SGI=SGI*RHK*.5
  4981.       RETURN
  4982. C
  4983. 18    FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5)
  4984.       END
  4985.       SUBROUTINE HINTG (XI,YI,ZI)
  4986. C ***
  4987. C     DOUBLE PRECISION 6/4/85
  4988. C
  4989.       IMPLICIT REAL*8(A-H,O-Z)
  4990. C ***
  4991. C     HINTG COMPUTES THE H FIELD OF A PATCH CURRENT
  4992.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,GAM
  4993.      1,F1X,F1Y,F1Z,F2X,F2Y,F2Z,RRV,RRH,T1,FRATI
  4994.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  4995.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  4996.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  4997.      1IPERF,T1,T2
  4998. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  4999. C    1J,IND1), (T2ZJ,IND2)
  5000.       DATA FPI/12.56637062D+0/,TP/6.283185308D+0/
  5001.       RX=XI-XJ
  5002.       RY=YI-YJ
  5003.       RFL=-1.
  5004.       EXK=(0.,0.)
  5005.       EYK=(0.,0.)
  5006.       EZK=(0.,0.)
  5007.       EXS=(0.,0.)
  5008.       EYS=(0.,0.)
  5009.       EZS=(0.,0.)
  5010.       DO 5 IP=1,KSYMP
  5011.       RFL=-RFL
  5012.       RZ=ZI-ZJ*RFL
  5013.       RSQ=RX*RX+RY*RY+RZ*RZ
  5014.       IF (RSQ.LT.1.D-20) GO TO 5
  5015.       R=SQRT(RSQ)
  5016.       RK=TP*R
  5017.       CR=COS(RK)
  5018.       SR=SIN(RK)
  5019.       GAM=-(DCMPLX(CR,-SR)+RK*DCMPLX(SR,CR))/(FPI*RSQ*R)*S
  5020.       EXC=GAM*RX
  5021.       EYC=GAM*RY
  5022.       EZC=GAM*RZ
  5023.       T1ZR=T1ZJ*RFL
  5024.       T2ZR=T2ZJ*RFL
  5025.       F1X=EYC*T1ZR-EZC*T1YJ
  5026.       F1Y=EZC*T1XJ-EXC*T1ZR
  5027.       F1Z=EXC*T1YJ-EYC*T1XJ
  5028.       F2X=EYC*T2ZR-EZC*T2YJ
  5029.       F2Y=EZC*T2XJ-EXC*T2ZR
  5030.       F2Z=EXC*T2YJ-EYC*T2XJ
  5031.       IF (IP.EQ.1) GO TO 4
  5032.       IF (IPERF.NE.1) GO TO 1
  5033.       F1X=-F1X
  5034.       F1Y=-F1Y
  5035.       F1Z=-F1Z
  5036.       F2X=-F2X
  5037.       F2Y=-F2Y
  5038.       F2Z=-F2Z
  5039.       GO TO 4
  5040. 1     XYMAG=SQRT(RX*RX+RY*RY)
  5041.       IF (XYMAG.GT.1.D-6) GO TO 2
  5042.       PX=0.
  5043.       PY=0.
  5044.       CTH=1.
  5045.       RRV=(1.,0.)
  5046.       GO TO 3
  5047. 2     PX=-RY/XYMAG
  5048.       PY=RX/XYMAG
  5049.       CTH=RZ/R
  5050.       RRV=SQRT(1.-ZRATI*ZRATI*(1.-CTH*CTH))
  5051. 3     RRH=ZRATI*CTH
  5052.       RRH=(RRH-RRV)/(RRH+RRV)
  5053.       RRV=ZRATI*RRV
  5054.       RRV=-(CTH-RRV)/(CTH+RRV)
  5055.       GAM=(F1X*PX+F1Y*PY)*(RRV-RRH)
  5056.       F1X=F1X*RRH+GAM*PX
  5057.       F1Y=F1Y*RRH+GAM*PY
  5058.       F1Z=F1Z*RRH
  5059.       GAM=(F2X*PX+F2Y*PY)*(RRV-RRH)
  5060.       F2X=F2X*RRH+GAM*PX
  5061.       F2Y=F2Y*RRH+GAM*PY
  5062.       F2Z=F2Z*RRH
  5063. 4     EXK=EXK+F1X
  5064.       EYK=EYK+F1Y
  5065.       EZK=EZK+F1Z
  5066.       EXS=EXS+F2X
  5067.       EYS=EYS+F2Y
  5068.       EZS=EZS+F2Z
  5069. 5     CONTINUE
  5070.       RETURN
  5071.       END
  5072.       SUBROUTINE HSFLD (XI,YI,ZI,AI)
  5073. C ***
  5074. C     DOUBLE PRECISION 6/4/85
  5075. C
  5076.       IMPLICIT REAL*8(A-H,O-Z)
  5077. C ***
  5078. C     HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT
  5079. C     ON A SEGMENT INCLUDING GROUND EFFECTS.
  5080.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1
  5081.      1,HPK,HPS,HPC,QX,QY,QZ,RRV,RRH,ZRATX,FRATI
  5082.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  5083.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  5084.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  5085.      1IPERF,T1,T2
  5086.       DATA ETA/376.73/
  5087.       XIJ=XI-XJ
  5088.       YIJ=YI-YJ
  5089.       RFL=-1.
  5090.       DO 7 IP=1,KSYMP
  5091.       RFL=-RFL
  5092.       SALPR=SALPJ*RFL
  5093.       ZIJ=ZI-RFL*ZJ
  5094.       ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
  5095.       RHOX=XIJ-CABJ*ZP
  5096.       RHOY=YIJ-SABJ*ZP
  5097.       RHOZ=ZIJ-SALPR*ZP
  5098.       RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
  5099.       IF (RH.GT.1.D-10) GO TO 1
  5100.       EXK=0.
  5101.       EYK=0.
  5102.       EZK=0.
  5103.       EXS=0.
  5104.       EYS=0.
  5105.       EZS=0.
  5106.       EXC=0.
  5107.       EYC=0.
  5108.       EZC=0.
  5109.       GO TO 7
  5110. 1     RHOX=RHOX/RH
  5111.       RHOY=RHOY/RH
  5112.       RHOZ=RHOZ/RH
  5113.       PHX=SABJ*RHOZ-SALPR*RHOY
  5114.       PHY=SALPR*RHOX-CABJ*RHOZ
  5115.       PHZ=CABJ*RHOY-SABJ*RHOX
  5116.       CALL HSFLX (S,RH,ZP,HPK,HPS,HPC)
  5117.       IF (IP.NE.2) GO TO 6
  5118.       IF (IPERF.EQ.1) GO TO 5
  5119.       ZRATX=ZRATI
  5120.       RMAG=SQRT(ZP*ZP+RH*RH)
  5121.       XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
  5122. C
  5123. C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
  5124. C
  5125.       IF (NRADL.EQ.0) GO TO 2
  5126.       XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ)
  5127.       YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ)
  5128.       RHOSPC=SQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2)
  5129.       IF (RHOSPC.GT.SCRWL) GO TO 2
  5130.       RRV=T1*RHOSPC*LOG(RHOSPC/T2)
  5131.       ZRATX=(RRV*ZRATI)/(ETA*ZRATI+RRV)
  5132. 2     IF (XYMAG.GT.1.D-6) GO TO 3
  5133. C
  5134. C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
  5135. C
  5136.       PX=0.
  5137.       PY=0.
  5138.       CTH=1.
  5139.       RRV=(1.,0.)
  5140.       GO TO 4
  5141. 3     PX=-YIJ/XYMAG
  5142.       PY=XIJ/XYMAG
  5143.       CTH=ZIJ/RMAG
  5144.       RRV=SQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH))
  5145. 4     RRH=ZRATX*CTH
  5146.       RRH=-(RRH-RRV)/(RRH+RRV)
  5147.       RRV=ZRATX*RRV
  5148.       RRV=(CTH-RRV)/(CTH+RRV)
  5149.       QY=(PHX*PX+PHY*PY)*(RRV-RRH)
  5150.       QX=QY*PX+PHX*RRH
  5151.       QY=QY*PY+PHY*RRH
  5152.       QZ=PHZ*RRH
  5153.       EXK=EXK-HPK*QX
  5154.       EYK=EYK-HPK*QY
  5155.       EZK=EZK-HPK*QZ
  5156.       EXS=EXS-HPS*QX
  5157.       EYS=EYS-HPS*QY
  5158.       EZS=EZS-HPS*QZ
  5159.       EXC=EXC-HPC*QX
  5160.       EYC=EYC-HPC*QY
  5161.       EZC=EZC-HPC*QZ
  5162.       GO TO 7
  5163. 5     EXK=EXK-HPK*PHX
  5164.       EYK=EYK-HPK*PHY
  5165.       EZK=EZK-HPK*PHZ
  5166.       EXS=EXS-HPS*PHX
  5167.       EYS=EYS-HPS*PHY
  5168.       EZS=EZS-HPS*PHZ
  5169.       EXC=EXC-HPC*PHX
  5170.       EYC=EYC-HPC*PHY
  5171.       EZC=EZC-HPC*PHZ
  5172.       GO TO 7
  5173. 6     EXK=HPK*PHX
  5174.       EYK=HPK*PHY
  5175.       EZK=HPK*PHZ
  5176.       EXS=HPS*PHX
  5177.       EYS=HPS*PHY
  5178.       EZS=HPS*PHZ
  5179.       EXC=HPC*PHX
  5180.       EYC=HPC*PHY
  5181.       EZC=HPC*PHZ
  5182. 7     CONTINUE
  5183.       RETURN
  5184.       END
  5185.       SUBROUTINE HSFLX (S,RH,ZPX,HPK,HPS,HPC)
  5186. C ***
  5187. C     DOUBLE PRECISION 6/4/85
  5188. C
  5189.       IMPLICIT REAL*8(A-H,O-Z)
  5190. C ***
  5191. C     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
  5192.       COMPLEX*16 FJ,FJK,EKR1,EKR2,T1,T2,CONS,HPS,HPC,HPK
  5193.       DIMENSION FJX(2), FJKX(2)
  5194.       EQUIVALENCE (FJ,FJX), (FJK,FJKX)
  5195.       DATA TP/6.283185308D+0/,FJX/0.,1./,FJKX/0.,-6.283185308D+0/
  5196.       DATA PI8/25.13274123D+0/
  5197.       IF (RH.LT.1.D-10) GO TO 6
  5198.       IF (ZPX.LT.0.) GO TO 1
  5199.       ZP=ZPX
  5200.       HSS=1.
  5201.       GO TO 2
  5202. 1     ZP=-ZPX
  5203.       HSS=-1.
  5204. 2     DH=.5*S
  5205.       Z1=ZP+DH
  5206.       Z2=ZP-DH
  5207.       IF (Z2.LT.1.D-7) GO TO 3
  5208.       RHZ=RH/Z2
  5209.       GO TO 4
  5210. 3     RHZ=1.
  5211. 4     DK=TP*DH
  5212.       CDK=COS(DK)
  5213.       SDK=SIN(DK)
  5214.       CALL HFK (-DK,DK,RH*TP,ZP*TP,HKR,HKI)
  5215.       HPK=DCMPLX(HKR,HKI)
  5216.       IF (RHZ.LT.1.D-3) GO TO 5
  5217.       RH2=RH*RH
  5218.       R1=SQRT(RH2+Z1*Z1)
  5219.       R2=SQRT(RH2+Z2*Z2)
  5220.       EKR1=EXP(FJK*R1)
  5221.       EKR2=EXP(FJK*R2)
  5222.       T1=Z1*EKR1/R1
  5223.       T2=Z2*EKR2/R2
  5224.       HPS=(CDK*(EKR2-EKR1)-FJ*SDK*(T2+T1))*HSS
  5225.       HPC=-SDK*(EKR2+EKR1)-FJ*CDK*(T2-T1)
  5226.       CONS=-FJ/(2.*TP*RH)
  5227.       HPS=CONS*HPS
  5228.       HPC=CONS*HPC
  5229.       RETURN
  5230. 5     EKR1=DCMPLX(CDK,SDK)/(Z2*Z2)
  5231.       EKR2=DCMPLX(CDK,-SDK)/(Z1*Z1)
  5232.       T1=TP*(1./Z1-1./Z2)
  5233.       T2=EXP(FJK*ZP)*RH/PI8
  5234.       HPS=T2*(T1+(EKR1+EKR2)*SDK)*HSS
  5235.       HPC=T2*(-FJ*T1+(EKR1-EKR2)*CDK)
  5236.       RETURN
  5237. 6     HPS=(0.,0.)
  5238.       HPC=(0.,0.)
  5239.       HPK=(0.,0.)
  5240.       RETURN
  5241.       END
  5242.       SUBROUTINE INTRP (X,Y,F1,F2,F3,F4)
  5243. C ***
  5244. C     DOUBLE PRECISION 6/4/85
  5245. C
  5246.       IMPLICIT REAL*8(A-H,O-Z)
  5247. C ***
  5248. C
  5249. C     INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF
  5250. C     4 FUNCTIONS AT THE POINT (X,Y).
  5251. C
  5252.       COMPLEX*16 F1,F2,F3,F4,A,B,C,D,FX1,FX2,FX3,FX4,P1,P2,P3,P4,A11,A12
  5253.      1,A13,A14,A21,A22,A23,A24,A31,A32,A33,A34,A41,A42,A43,A44,B11,B12
  5254.      2,B13,B14,B21,B22,B23,B24,B31,B32,B33,B34,B41,B42,B43,B44,C11,C12
  5255.      3,C13,C14,C21,C22,C23,C24,C31,C32,C33,C34,C41,C42,C43,C44,D11,D12
  5256.      4,D13,D14,D21,D22,D23,D24,D31,D32,D33,D34,D41,D42,D43,D44
  5257.       COMPLEX*16 AR1,AR2,AR3,ARL1,ARL2,ARL3,EPSCF
  5258.       COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
  5259.      1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
  5260.       DIMENSION NDA(3), NDPA(3)
  5261.       DIMENSION A(4,4), B(4,4), C(4,4), D(4,4), ARL1(1), ARL2(1), ARL3(1
  5262.      1)
  5263.       EQUIVALENCE (A(1,1),A11), (A(1,2),A12), (A(1,3),A13), (A(1,4),A14)
  5264.       EQUIVALENCE (A(2,1),A21), (A(2,2),A22), (A(2,3),A23), (A(2,4),A24)
  5265.       EQUIVALENCE (A(3,1),A31), (A(3,2),A32), (A(3,3),A33), (A(3,4),A34)
  5266.       EQUIVALENCE (A(4,1),A41), (A(4,2),A42), (A(4,3),A43), (A(4,4),A44)
  5267.       EQUIVALENCE (B(1,1),B11), (B(1,2),B12), (B(1,3),B13), (B(1,4),B14)
  5268.       EQUIVALENCE (B(2,1),B21), (B(2,2),B22), (B(2,3),B23), (B(2,4),B24)
  5269.       EQUIVALENCE (B(3,1),B31), (B(3,2),B32), (B(3,3),B33), (B(3,4),B34)
  5270.       EQUIVALENCE (B(4,1),B41), (B(4,2),B42), (B(4,3),B43), (B(4,4),B44)
  5271.       EQUIVALENCE (C(1,1),C11), (C(1,2),C12), (C(1,3),C13), (C(1,4),C14)
  5272.       EQUIVALENCE (C(2,1),C21), (C(2,2),C22), (C(2,3),C23), (C(2,4),C24)
  5273.       EQUIVALENCE (C(3,1),C31), (C(3,2),C32), (C(3,3),C33), (C(3,4),C34)
  5274.       EQUIVALENCE (C(4,1),C41), (C(4,2),C42), (C(4,3),C43), (C(4,4),C44)
  5275.       EQUIVALENCE (D(1,1),D11), (D(1,2),D12), (D(1,3),D13), (D(1,4),D14)
  5276.       EQUIVALENCE (D(2,1),D21), (D(2,2),D22), (D(2,3),D23), (D(2,4),D24)
  5277.       EQUIVALENCE (D(3,1),D31), (D(3,2),D32), (D(3,3),D33), (D(3,4),D34)
  5278.       EQUIVALENCE (D(4,1),D41), (D(4,2),D42), (D(4,3),D43), (D(4,4),D44)
  5279.       EQUIVALENCE (ARL1,AR1), (ARL2,AR2), (ARL3,AR3), (XS2,XSA(2)), (YS3
  5280.      1,YSA(3))
  5281.       DATA IXS,IYS,IGRS/-10,-10,-10/,DX,DY,XS,YS/1.,1.,0.,0./
  5282.       DATA NDA/11,17,9/,NDPA/110,85,72/,IXEG,IYEG/0,0/
  5283.       IF (X.LT.XS.OR.Y.LT.YS) GO TO 1
  5284.       IX=INT((X-XS)/DX)+1
  5285.       IY=INT((Y-YS)/DY)+1
  5286. C
  5287. C     IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD
  5288. C     VALUES ARE REUSED
  5289. C
  5290.       IF (IX.LT.IXEG.OR.IY.LT.IYEG) GO TO 1
  5291.       IF (IABS(IX-IXS).LT.2.AND.IABS(IY-IYS).LT.2) GO TO 12
  5292. C
  5293. C     DETERMINE CORRECT GRID AND GRID REGION
  5294. C
  5295. 1     IF (X.GT.XS2) GO TO 2
  5296.       IGR=1
  5297.       GO TO 3
  5298. 2     IGR=2
  5299.       IF (Y.GT.YS3) IGR=3
  5300. 3     IF (IGR.EQ.IGRS) GO TO 4
  5301.       IGRS=IGR
  5302.       DX=DXA(IGRS)
  5303.       DY=DYA(IGRS)
  5304.       XS=XSA(IGRS)
  5305.       YS=YSA(IGRS)
  5306.       NXM2=NXA(IGRS)-2
  5307.       NYM2=NYA(IGRS)-2
  5308.       NXMS=((NXM2+1)/3)*3+1
  5309.       NYMS=((NYM2+1)/3)*3+1
  5310.       ND=NDA(IGRS)
  5311.       NDP=NDPA(IGRS)
  5312.       IX=INT((X-XS)/DX)+1
  5313.       IY=INT((Y-YS)/DY)+1
  5314. 4     IXS=((IX-1)/3)*3+2
  5315.       IF (IXS.LT.2) IXS=2
  5316.       IXEG=-10000
  5317.       IF (IXS.LE.NXM2) GO TO 5
  5318.       IXS=NXM2
  5319.       IXEG=NXMS
  5320. 5     IYS=((IY-1)/3)*3+2
  5321.       IF (IYS.LT.2) IYS=2
  5322.       IYEG=-10000
  5323.       IF (IYS.LE.NYM2) GO TO 6
  5324.       IYS=NYM2
  5325.       IYEG=NYMS
  5326. C
  5327. C     COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID
  5328. C     VALUES OF Y FOR EACH OF THE 4 FUNCTIONS
  5329. C
  5330. 6     IADZ=IXS+(IYS-3)*ND-NDP
  5331.       DO 11 K=1,4
  5332.       IADZ=IADZ+NDP
  5333.       IADD=IADZ
  5334.       DO 11 I=1,4
  5335.       IADD=IADD+ND
  5336.       GO TO (7,8,9), IGRS
  5337. C     P1=AR1(IXS-1,IYS-2+I,K)
  5338. 7     P1=ARL1(IADD-1)
  5339.       P2=ARL1(IADD)
  5340.       P3=ARL1(IADD+1)
  5341.       P4=ARL1(IADD+2)
  5342.       GO TO 10
  5343. 8     P1=ARL2(IADD-1)
  5344.       P2=ARL2(IADD)
  5345.       P3=ARL2(IADD+1)
  5346.       P4=ARL2(IADD+2)
  5347.       GO TO 10
  5348. 9     P1=ARL3(IADD-1)
  5349.       P2=ARL3(IADD)
  5350.       P3=ARL3(IADD+1)
  5351.       P4=ARL3(IADD+2)
  5352. 10    A(I,K)=(P4-P1+3.*(P2-P3))*.1666666667D+0
  5353.       B(I,K)=(P1-2.*P2+P3)*.5
  5354.       C(I,K)=P3-(2.*P1+3.*P2+P4)*.1666666667D+0
  5355. 11    D(I,K)=P2
  5356.       XZ=(IXS-1)*DX+XS
  5357.       YZ=(IYS-1)*DY+YS
  5358. C
  5359. C     EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y
  5360. C     FOR EACH OF THE 4 FUNCTIONS.
  5361. C
  5362. 12    XX=(X-XZ)/DX
  5363.       YY=(Y-YZ)/DY
  5364.       FX1=((A11*XX+B11)*XX+C11)*XX+D11
  5365.       FX2=((A21*XX+B21)*XX+C21)*XX+D21
  5366.       FX3=((A31*XX+B31)*XX+C31)*XX+D31
  5367.       FX4=((A41*XX+B41)*XX+C41)*XX+D41
  5368.       P1=FX4-FX1+3.*(FX2-FX3)
  5369.       P2=3.*(FX1-2.*FX2+FX3)
  5370.       P3=6.*FX3-2.*FX1-3.*FX2-FX4
  5371.       F1=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2
  5372.       FX1=((A12*XX+B12)*XX+C12)*XX+D12
  5373.       FX2=((A22*XX+B22)*XX+C22)*XX+D22
  5374.       FX3=((A32*XX+B32)*XX+C32)*XX+D32
  5375.       FX4=((A42*XX+B42)*XX+C42)*XX+D42
  5376.       P1=FX4-FX1+3.*(FX2-FX3)
  5377.       P2=3.*(FX1-2.*FX2+FX3)
  5378.       P3=6.*FX3-2.*FX1-3.*FX2-FX4
  5379.       F2=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2
  5380.       FX1=((A13*XX+B13)*XX+C13)*XX+D13
  5381.       FX2=((A23*XX+B23)*XX+C23)*XX+D23
  5382.       FX3=((A33*XX+B33)*XX+C33)*XX+D33
  5383.       FX4=((A43*XX+B43)*XX+C43)*XX+D43
  5384.       P1=FX4-FX1+3.*(FX2-FX3)
  5385.       P2=3.*(FX1-2.*FX2+FX3)
  5386.       P3=6.*FX3-2.*FX1-3.*FX2-FX4
  5387.       F3=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2
  5388.       FX1=((A14*XX+B14)*XX+C14)*XX+D14
  5389.       FX2=((A24*XX+B24)*XX+C24)*XX+D24
  5390.       FX3=((A34*XX+B34)*XX+C34)*XX+D34
  5391.       FX4=((A44*XX+B44)*XX+C44)*XX+D44
  5392.       P1=FX4-FX1+3.*(FX2-FX3)
  5393.       P2=3.*(FX1-2.*FX2+FX3)
  5394.       P3=6.*FX3-2.*FX1-3.*FX2-FX4
  5395.       F4=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2
  5396.       RETURN
  5397.       END
  5398.       SUBROUTINE INTX (EL1,EL2,B,IJ,SGR,SGI)
  5399. C ***
  5400. C     DOUBLE PRECISION 6/4/85
  5401. C
  5402.       IMPLICIT REAL*8(A-H,O-Z)
  5403. C ***
  5404. C
  5405. C     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
  5406. C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUE
  5407. C     IS SUPPLIED BY SUBROUTINE GF.
  5408. C
  5409.       DATA NX,NM,NTS,RX/1,65536,4,1.D-4/
  5410.       Z=EL1
  5411.       ZE=EL2
  5412.       IF (IJ.EQ.0) ZE=0.
  5413.       S=ZE-Z
  5414.       FNM=NM
  5415.       EP=S/(10.*FNM)
  5416.       ZEND=ZE-EP
  5417.       SGR=0.
  5418.       SGI=0.
  5419.       NS=NX
  5420.       NT=0
  5421.       CALL GF (Z,G1R,G1I)
  5422. 1     FNS=NS
  5423.       DZ=S/FNS
  5424.       ZP=Z+DZ
  5425.       IF (ZP-ZE) 3,3,2
  5426. 2     DZ=ZE-Z
  5427.       IF (ABS(DZ)-EP) 17,17,3
  5428. 3     DZOT=DZ*.5
  5429.       ZP=Z+DZOT
  5430.       CALL GF (ZP,G3R,G3I)
  5431.       ZP=Z+DZ
  5432.       CALL GF (ZP,G5R,G5I)
  5433. 4     T00R=(G1R+G5R)*DZOT
  5434.       T00I=(G1I+G5I)*DZOT
  5435.       T01R=(T00R+DZ*G3R)*0.5
  5436.       T01I=(T00I+DZ*G3I)*0.5
  5437.       T10R=(4.0*T01R-T00R)/3.0
  5438.       T10I=(4.0*T01I-T00I)/3.0
  5439. C
  5440. C     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.
  5441. C
  5442.       CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.)
  5443.       IF (TE1I-RX) 5,5,6
  5444. 5     IF (TE1R-RX) 8,8,6
  5445. 6     ZP=Z+DZ*0.25
  5446.       CALL GF (ZP,G2R,G2I)
  5447.       ZP=Z+DZ*0.75
  5448.       CALL GF (ZP,G4R,G4I)
  5449.       T02R=(T01R+DZOT*(G2R+G4R))*0.5
  5450.       T02I=(T01I+DZOT*(G2I+G4I))*0.5
  5451.       T11R=(4.0*T02R-T01R)/3.0
  5452.       T11I=(4.0*T02I-T01I)/3.0
  5453.       T20R=(16.0*T11R-T10R)/15.0
  5454.       T20I=(16.0*T11I-T10I)/15.0
  5455. C
  5456. C     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.
  5457. C
  5458.       CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.)
  5459.       IF (TE2I-RX) 7,7,14
  5460. 7     IF (TE2R-RX) 9,9,14
  5461. 8     SGR=SGR+T10R
  5462.       SGI=SGI+T10I
  5463.       NT=NT+2
  5464.       GO TO 10
  5465. 9     SGR=SGR+T20R
  5466.       SGI=SGI+T20I
  5467.       NT=NT+1
  5468. 10    Z=Z+DZ
  5469.       IF (Z-ZEND) 11,17,17
  5470. 11    G1R=G5R
  5471.       G1I=G5I
  5472.       IF (NT-NTS) 1,12,12
  5473. 12    IF (NS-NX) 1,1,13
  5474. C
  5475. C     DOUBLE STEP SIZE
  5476. C
  5477. 13    NS=NS/2
  5478.       NT=1
  5479.       GO TO 1
  5480. 14    NT=0
  5481.       IF (NS-NM) 16,15,15
  5482. 15    WRITE(3,20)  Z
  5483.       GO TO 9
  5484. C
  5485. C     HALVE STEP SIZE
  5486. C
  5487. 16    NS=NS*2
  5488.       FNS=NS
  5489.       DZ=S/FNS
  5490.       DZOT=DZ*0.5
  5491.       G5R=G3R
  5492.       G5I=G3I
  5493.       G3R=G2R
  5494.       G3I=G2I
  5495.       GO TO 4
  5496. 17    CONTINUE
  5497.       IF (IJ) 19,18,19
  5498. C
  5499. C     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM
  5500. C
  5501. 18    SGR=2.*(SGR+LOG((SQRT(B*B+S*S)+S)/B))
  5502.       SGI=2.*SGI
  5503. 19    CONTINUE
  5504.       RETURN
  5505. C
  5506. 20    FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5)
  5507.       END
  5508.       FUNCTION ISEGNO (ITAGI,MX)
  5509. C ***
  5510. C     DOUBLE PRECISION 6/4/85
  5511. C
  5512.       INCLUDE 'NEC2DPAR.INC'
  5513.       IMPLICIT REAL*8(A-H,O-Z)
  5514. C ***
  5515. C
  5516. C     ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE
  5517. C     TAG NUMBER ITAGI.  IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.
  5518. C
  5519.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  5520.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  5521.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  5522.      &IPSYM
  5523.       IF (MX.GT.0) GO TO 1
  5524.       WRITE(3,6)
  5525.       STOP
  5526. 1     ICNT=0
  5527.       IF (ITAGI.NE.0) GO TO 2
  5528.       ISEGNO=MX
  5529.       RETURN
  5530. 2     IF (N.LT.1) GO TO 4
  5531.       DO 3 I=1,N
  5532.       IF (ITAG(I).NE.ITAGI) GO TO 3
  5533.       ICNT=ICNT+1
  5534.       IF (ICNT.EQ.MX) GO TO 5
  5535. 3     CONTINUE
  5536. 4     WRITE(3,7)  ITAGI
  5537.       STOP
  5538. 5     ISEGNO=I
  5539.       RETURN
  5540. C
  5541. 6     FORMAT (4X,91HCHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN
  5542.      1 A GROUP OF EQUAL TAGS MUST NOT BE ZERO)
  5543. 7     FORMAT (///,10X,26HNO SEGMENT HAS AN ITAG OF ,I5)
  5544.       END
  5545.       SUBROUTINE LFACTR (A,NROW,IX1,IX2,IP)
  5546. C ***
  5547. C     DOUBLE PRECISION 6/4/85
  5548. C
  5549.       INCLUDE 'NEC2DPAR.INC'
  5550.       IMPLICIT REAL*8(A-H,O-Z)
  5551. C ***
  5552. C
  5553. C     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
  5554. C     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE
  5555. C     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST
  5556. C     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN
  5557. C     RALSTONS TEXT.
  5558. C
  5559.       COMPLEX*16 A,D,AJR
  5560.       INTEGER R,R1,R2,PJ,PR
  5561.       LOGICAL L1,L2,L3
  5562.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  5563.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  5564.       COMMON /SCRATM/ D(2*MAXSEG)
  5565.       DIMENSION A(NROW,1), IP(NROW)
  5566.       IFLG=0
  5567. C
  5568. C     INITIALIZE R1,R2,J1,J2
  5569. C
  5570.       L1=IX1.EQ.1.AND.IX2.EQ.2
  5571.       L2=(IX2-1).EQ.IX1
  5572.       L3=IX2.EQ.NBLSYM
  5573.       IF (L1) GO TO 1
  5574.       GO TO 2
  5575. 1     R1=1
  5576.       R2=2*NPSYM
  5577.       J1=1
  5578.       J2=-1
  5579.       GO TO 5
  5580. 2     R1=NPSYM+1
  5581.       R2=2*NPSYM
  5582.       J1=(IX1-1)*NPSYM+1
  5583.       IF (L2) GO TO 3
  5584.       GO TO 4
  5585. 3     J2=J1+NPSYM-2
  5586.       GO TO 5
  5587. 4     J2=J1+NPSYM-1
  5588. 5     IF (L3) R2=NPSYM+NLSYM
  5589.       DO 16 R=R1,R2
  5590. C
  5591. C     STEP 1
  5592. C
  5593.       DO 6 K=J1,NROW
  5594.       D(K)=A(K,R)
  5595. 6     CONTINUE
  5596. C
  5597. C     STEPS 2 AND 3
  5598. C
  5599.       IF (L1.OR.L2) J2=J2+1
  5600.       IF (J1.GT.J2) GO TO 9
  5601.       IXJ=0
  5602.       DO 8 J=J1,J2
  5603.       IXJ=IXJ+1
  5604.       PJ=IP(J)
  5605.       AJR=D(PJ)
  5606.       A(J,R)=AJR
  5607.       D(PJ)=D(J)
  5608.       JP1=J+1
  5609.       DO 7 I=JP1,NROW
  5610.       D(I)=D(I)-A(I,IXJ)*AJR
  5611. 7     CONTINUE
  5612. 8     CONTINUE
  5613. 9     CONTINUE
  5614. C
  5615. C     STEP 4
  5616. C
  5617.       J2P1=J2+1
  5618.       IF (L1.OR.L2) GO TO 11
  5619.       IF (NROW.LT.J2P1) GO TO 16
  5620.       DO 10 I=J2P1,NROW
  5621.       A(I,R)=D(I)
  5622. 10    CONTINUE
  5623.       GO TO 16
  5624. 11    DMAX=DREAL(D(J2P1)*DCONJG(D(J2P1)))
  5625.       IP(J2P1)=J2P1
  5626.       J2P2=J2+2
  5627.       IF (J2P2.GT.NROW) GO TO 13
  5628.       DO 12 I=J2P2,NROW
  5629.       ELMAG=DREAL(D(I)*DCONJG(D(I)))
  5630.       IF (ELMAG.LT.DMAX) GO TO 12
  5631.       DMAX=ELMAG
  5632.       IP(J2P1)=I
  5633. 12    CONTINUE
  5634. 13    CONTINUE
  5635.       IF (DMAX.LT.1.D-10) IFLG=1
  5636.       PR=IP(J2P1)
  5637.       A(J2P1,R)=D(PR)
  5638.       D(PR)=D(J2P1)
  5639. C
  5640. C     STEP 5
  5641. C
  5642.       IF (J2P2.GT.NROW) GO TO 15
  5643.       AJR=1./A(J2P1,R)
  5644.       DO 14 I=J2P2,NROW
  5645.       A(I,R)=D(I)*AJR
  5646. 14    CONTINUE
  5647. 15    CONTINUE
  5648.       IF (IFLG.EQ.0) GO TO 16
  5649.       WRITE(3,17)  J2,DMAX
  5650.       IFLG=0
  5651. 16    CONTINUE
  5652.       RETURN
  5653. C
  5654. 17    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)
  5655.       END
  5656.       SUBROUTINE LOAD (LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC)
  5657. C ***
  5658. C     DOUBLE PRECISION 6/4/85
  5659. C
  5660.       INCLUDE 'NEC2DPAR.INC'
  5661.       IMPLICIT REAL*8(A-H,O-Z)
  5662. C ***
  5663. C
  5664. C     LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS
  5665. C     TYPES OF LOADING
  5666. C
  5667.       COMPLEX*16 ZARRAY,ZT,TPCJ,ZINT
  5668.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  5669.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  5670.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  5671.      &IPSYM
  5672.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  5673.       DIMENSION LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(1)
  5674.      1, ZLC(1), TPCJX(2)
  5675.       EQUIVALENCE (TPCJ,TPCJX)
  5676.       DATA TPCJX/0.,1.883698955D+9/
  5677. C
  5678. C     WRITE(3,HEADING)
  5679. C
  5680.       WRITE(3,25)
  5681. C
  5682. C     INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING
  5683. C     INFORMATION.
  5684. C
  5685.       DO 1 I=N2,N
  5686.  1    ZARRAY(I)=(0.,0.)
  5687.       IWARN=0
  5688. C
  5689. C     CYCLE OVER LOADING CARDS
  5690. C
  5691.       ISTEP=0
  5692.  2    ISTEP=ISTEP+1
  5693.       IF (ISTEP.LE.NLOAD) GO TO 5
  5694.       IF (IWARN.EQ.1) WRITE(3,26)
  5695.       IF (N1+2*M1.GT.0) GO TO 4
  5696.       NOP=N/NP
  5697.       IF (NOP.EQ.1) GO TO 4
  5698.       DO 3 I=1,NP
  5699.       ZT=ZARRAY(I)
  5700.       L1=I
  5701.       DO 3 L2=2,NOP
  5702.       L1=L1+NP
  5703.  3    ZARRAY(L1)=ZT
  5704.  4    RETURN
  5705.  5    IF (LDTYP(ISTEP).LE.5) GO TO 6
  5706.       WRITE(3,27)  LDTYP(ISTEP)
  5707.       STOP
  5708.  6    LDTAGS=LDTAG(ISTEP)
  5709.       JUMP=LDTYP(ISTEP)+1
  5710.       ICHK=0
  5711. C
  5712. C     SEARCH SEGMENTS FOR PROPER ITAGS
  5713. C
  5714.       L1=N2
  5715.       L2=N
  5716.       IF (LDTAGS.NE.0) GO TO 7
  5717.       IF (LDTAGF(ISTEP).EQ.0.AND.LDTAGT(ISTEP).EQ.0) GO TO 7
  5718.       L1=LDTAGF(ISTEP)
  5719.       L2=LDTAGT(ISTEP)
  5720.       IF (L1.GT.N1) GO TO 7
  5721.       WRITE(3,29)
  5722.       STOP
  5723.  7    DO 17 I=L1,L2
  5724.       IF (LDTAGS.EQ.0) GO TO 8
  5725.       IF (LDTAGS.NE.ITAG(I)) GO TO 17
  5726.       IF (LDTAGF(ISTEP).EQ.0) GO TO 8
  5727.       ICHK=ICHK+1
  5728.       IF (ICHK.GE.LDTAGF(ISTEP).AND.ICHK.LE.LDTAGT(ISTEP)) GO TO 9
  5729.       GO TO 17
  5730.  8    ICHK=1
  5731. C
  5732. C     CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATE
  5733. C     SECTION FOR LOADING TYPE
  5734. C
  5735.  9    GO TO (10,11,12,13,14,15), JUMP
  5736.  10   ZT=ZLR(ISTEP)/SI(I)+TPCJ*ZLI(ISTEP)/(SI(I)*WLAM)
  5737.       IF (ABS(ZLC(ISTEP)).GT.1.D-20) ZT=ZT+WLAM/(TPCJ*SI(I)*ZLC(ISTEP))
  5738.       GO TO 16
  5739.  11   ZT=TPCJ*SI(I)*ZLC(ISTEP)/WLAM
  5740.       IF (ABS(ZLI(ISTEP)).GT.1.D-20) ZT=ZT+SI(I)*WLAM/(TPCJ*ZLI(ISTEP))
  5741.       IF (ABS(ZLR(ISTEP)).GT.1.D-20) ZT=ZT+SI(I)/ZLR(ISTEP)
  5742.       ZT=1./ZT
  5743.       GO TO 16
  5744.  12   ZT=ZLR(ISTEP)*WLAM+TPCJ*ZLI(ISTEP)
  5745.       IF (ABS(ZLC(ISTEP)).GT.1.D-20) ZT=ZT+1./(TPCJ*SI(I)*SI(I)*ZLC(ISTE
  5746.      1P))
  5747.       GO TO 16
  5748.  13   ZT=TPCJ*SI(I)*SI(I)*ZLC(ISTEP)
  5749.       IF (ABS(ZLI(ISTEP)).GT.1.D-20) ZT=ZT+1./(TPCJ*ZLI(ISTEP))
  5750.       IF (ABS(ZLR(ISTEP)).GT.1.D-20) ZT=ZT+1./(ZLR(ISTEP)*WLAM)
  5751.       ZT=1./ZT
  5752.       GO TO 16
  5753.  14   ZT=DCMPLX(ZLR(ISTEP),ZLI(ISTEP))/SI(I)
  5754.       GO TO 16
  5755.  15   ZT=ZINT(ZLR(ISTEP)*WLAM,BI(I))
  5756.  16   IF ((ABS(DREAL(ZARRAY(I)))+ABS(DIMAG(ZARRAY(I)))).GT.1.D-20)
  5757.      1IWARN=1
  5758.       ZARRAY(I)=ZARRAY(I)+ZT
  5759.  17   CONTINUE
  5760.       IF (ICHK.NE.0) GO TO 18
  5761.       WRITE(3,28)  LDTAGS
  5762.       STOP
  5763. C
  5764. C     PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT
  5765. C
  5766.  18   GO TO (19,20,21,22,23,24), JUMP
  5767.  19   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP
  5768.      1),ZLC(ISTEP),0.,0.,0.,' SERIES ')
  5769.       GO TO 2
  5770.  20   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP
  5771.      1),ZLC(ISTEP),0.,0.,0.,'PARALLEL')
  5772.       GO TO 2
  5773.  21   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP
  5774.      1),ZLC(ISTEP),0.,0.,0.,' SERIES (PER METER) ')
  5775.       GO TO 2
  5776.  22   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP
  5777.      1),ZLC(ISTEP),0.,0.,0.,'PARALLEL (PER METER)')
  5778.       GO TO 2
  5779.  23   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.,0.,0.,ZLR(ISTEP),
  5780.      1ZLI(ISTEP),0.,'FIXED IMPEDANCE ')
  5781.       GO TO 2
  5782.  24   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.,0.,0.,0.,0.,ZLR(I
  5783.      1STEP),'  WIRE  ')
  5784.       GO TO 2
  5785. C
  5786.  25   FORMAT (//,7X,8HLOCATION,10X,10HRESISTANCE,3X,10HINDUCTANCE,2X,11H
  5787.      1CAPACITANCE,7X,16HIMPEDANCE (OHMS),5X,12HCONDUCTIVITY,4X,4HTYPE,/,
  5788.      24X,4HITAG,10H FROM THRU,10X,4HOHMS,8X,6HHENRYS,7X,6HFARADS,8X,4HRE
  5789.      3AL,6X,9HIMAGINARY,4X,10HMHOS/METER)
  5790.  26   FORMAT (/,10X,74HNOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED
  5791.      1 TWICE - IMPEDANCES ADDED)
  5792.  27   FORMAT (/,10X,46HIMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ,I3
  5793.      1)
  5794.  28   FORMAT (/,10X,50HLOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =
  5795.      1 ,I5)
  5796.  29   FORMAT (63H ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F.
  5797.      1 SECTION)
  5798.       END
  5799.       SUBROUTINE LTSOLV (A,NROW,IX,B,NEQ,NRH,IFL1,IFL2)
  5800. C ***
  5801. C     DOUBLE PRECISION 6/4/85
  5802. C
  5803.       INCLUDE 'NEC2DPAR.INC'
  5804.       IMPLICIT REAL*8(A-H,O-Z)
  5805. C ***
  5806. C
  5807. C     LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW
  5808. C     VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF
  5809. C     THE ORIGINAL COEFFICIENT MATRIX.  THE LU(T) DECOMPOSITION IS
  5810. C     STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN
  5811. C     BLOCKS OF DESCENDING ORDER.
  5812. C
  5813.       COMPLEX*16 A,B,Y,SUM
  5814.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  5815.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  5816.       COMMON /SCRATM/ Y(2*MAXSEG)
  5817.       DIMENSION A(NROW,NROW), B(NEQ,NRH), IX(NEQ)
  5818. C
  5819. C     FORWARD SUBSTITUTION
  5820. C
  5821.       I2=2*NPSYM*NROW
  5822.       DO 4 IXBLK1=1,NBLSYM
  5823.       CALL BLCKIN (A,IFL1,1,I2,1,121)
  5824.       K2=NPSYM
  5825.       IF (IXBLK1.EQ.NBLSYM) K2=NLSYM
  5826.       JST=(IXBLK1-1)*NPSYM
  5827.       DO 4 IC=1,NRH
  5828.       J=JST
  5829.       DO 3 K=1,K2
  5830.       JM1=J
  5831.       J=J+1
  5832.       SUM=(0.,0.)
  5833.       IF (JM1.LT.1) GO TO 2
  5834.       DO 1 I=1,JM1
  5835. 1     SUM=SUM+A(I,K)*B(I,IC)
  5836. 2     B(J,IC)=(B(J,IC)-SUM)/A(J,K)
  5837. 3     CONTINUE
  5838. 4     CONTINUE
  5839. C
  5840. C     BACKWARD SUBSTITUTION
  5841. C
  5842.       JST=NROW+1
  5843.       DO 8 IXBLK1=1,NBLSYM
  5844.       CALL BLCKIN (A,IFL2,1,I2,1,122)
  5845.       K2=NPSYM
  5846.       IF (IXBLK1.EQ.1) K2=NLSYM
  5847.       DO 7 IC=1,NRH
  5848.       KP=K2+1
  5849.       J=JST
  5850.       DO 6 K=1,K2
  5851.       KP=KP-1
  5852.       JP1=J
  5853.       J=J-1
  5854.       SUM=(0.,0.)
  5855.       IF (NROW.LT.JP1) GO TO 6
  5856.       DO 5 I=JP1,NROW
  5857. 5     SUM=SUM+A(I,KP)*B(I,IC)
  5858.       B(J,IC)=B(J,IC)-SUM
  5859. 6     CONTINUE
  5860. 7     CONTINUE
  5861. 8     JST=JST-K2
  5862. C
  5863. C     UNSCRAMBLE SOLUTION
  5864. C
  5865.       DO 10 IC=1,NRH
  5866.       DO 9 I=1,NROW
  5867.       IXI=IX(I)
  5868. 9     Y(IXI)=B(I,IC)
  5869.       DO 10 I=1,NROW
  5870. 10    B(I,IC)=Y(I)
  5871.       RETURN
  5872.       END
  5873.       SUBROUTINE LUNSCR (A,NROW,NOP,IX,IP,IU2,IU3,IU4)
  5874. C ***
  5875. C     DOUBLE PRECISION 6/4/85
  5876. C
  5877.       IMPLICIT REAL*8(A-H,O-Z)
  5878. C ***
  5879. C
  5880. C     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX
  5881. C
  5882.       COMPLEX*16 A,TEMP
  5883.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  5884.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  5885.       DIMENSION A(NROW,1), IP(NROW), IX(NROW)
  5886.       I1=1
  5887.       I2=2*NPSYM*NROW
  5888.       NM1=NROW-1
  5889.       REWIND IU2
  5890.       REWIND IU3
  5891.       REWIND IU4
  5892.       DO 9 KK=1,NOP
  5893.       KA=(KK-1)*NROW
  5894.       DO 4 IXBLK1=1,NBLSYM
  5895.       CALL BLCKIN (A,IU2,I1,I2,1,121)
  5896.       K1=(IXBLK1-1)*NPSYM+2
  5897.       IF (NM1.LT.K1) GO TO 3
  5898.       J2=0
  5899.       DO 2 K=K1,NM1
  5900.       IF (J2.LT.NPSYM) J2=J2+1
  5901.       IPK=IP(K+KA)
  5902.       DO 1 J=1,J2
  5903.       TEMP=A(K,J)
  5904.       A(K,J)=A(IPK,J)
  5905.       A(IPK,J)=TEMP
  5906. 1     CONTINUE
  5907. 2     CONTINUE
  5908. 3     CONTINUE
  5909.       CALL BLCKOT (A,IU3,I1,I2,1,122)
  5910. 4     CONTINUE
  5911.       DO 5 IXBLK1=1,NBLSYM
  5912.       BACKSPACE IU3
  5913.       IF (IXBLK1.NE.1) BACKSPACE IU3
  5914.       CALL BLCKIN (A,IU3,I1,I2,1,123)
  5915.       CALL BLCKOT (A,IU4,I1,I2,1,124)
  5916. 5     CONTINUE
  5917.       DO 6 I=1,NROW
  5918.       IX(I+KA)=I
  5919. 6     CONTINUE
  5920.       DO 7 I=1,NROW
  5921.       IPI=IP(I+KA)
  5922.       IXT=IX(I+KA)
  5923.       IX(I+KA)=IX(IPI+KA)
  5924.       IX(IPI+KA)=IXT
  5925. 7     CONTINUE
  5926.       IF (NOP.EQ.1) GO TO 9
  5927.       NB1=NBLSYM-1
  5928. C     SKIP NB1 LOGICAL RECORDS FORWARD
  5929.       DO 8 IXBLK1=1,NB1
  5930.       CALL BLCKIN (A,IU3,I1,I2,1,125)
  5931. 8     CONTINUE
  5932. 9     CONTINUE
  5933.       REWIND IU2
  5934.       REWIND IU3
  5935.       REWIND IU4
  5936.       RETURN
  5937.       END
  5938.       SUBROUTINE MOVE (ROX,ROY,ROZ,XS,YS,ZS,ITS,NRPT,ITGI)
  5939. C ***
  5940. C     DOUBLE PRECISION 6/4/85
  5941. C
  5942.       INCLUDE 'NEC2DPAR.INC'
  5943.       IMPLICIT REAL*8(A-H,O-Z)
  5944. C ***
  5945. C
  5946. C     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS
  5947. C     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.
  5948. C     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ
  5949. C     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS
  5950. C
  5951.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  5952.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  5953.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  5954.      &IPSYM
  5955.       COMMON /ANGL/ SALP(MAXSEG)
  5956.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y
  5957.      12(1), Z2(1)
  5958.       EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1))
  5959.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  5960.      12), (T2Z,ITAG)
  5961.       IF (ABS(ROX)+ABS(ROY).GT.1.D-10) IPSYM=IPSYM*3
  5962.       SPS=SIN(ROX)
  5963.       CPS=COS(ROX)
  5964.       STH=SIN(ROY)
  5965.       CTH=COS(ROY)
  5966.       SPH=SIN(ROZ)
  5967.       CPH=COS(ROZ)
  5968.       XX=CPH*CTH
  5969.       XY=CPH*STH*SPS-SPH*CPS
  5970.       XZ=CPH*STH*CPS+SPH*SPS
  5971.       YX=SPH*CTH
  5972.       YY=SPH*STH*SPS+CPH*CPS
  5973.       YZ=SPH*STH*CPS-CPH*SPS
  5974.       ZX=-STH
  5975.       ZY=CTH*SPS
  5976.       ZZ=CTH*CPS
  5977.       NRP=NRPT
  5978.       IF (NRPT.EQ.0) NRP=1
  5979.       IX=1
  5980.       IF (N.LT.N2) GO TO 3
  5981.       I1=ISEGNO(ITS,1)
  5982.       IF (I1.LT.N2) I1=N2
  5983.       IX=I1
  5984.       K=N
  5985.       IF (NRPT.EQ.0) K=I1-1
  5986.       DO 2 IR=1,NRP
  5987.       DO 1 I=I1,N
  5988.       K=K+1
  5989.       XI=X(I)
  5990.       YI=Y(I)
  5991.       ZI=Z(I)
  5992.       X(K)=XI*XX+YI*XY+ZI*XZ+XS
  5993.       Y(K)=XI*YX+YI*YY+ZI*YZ+YS
  5994.       Z(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  5995.       XI=X2(I)
  5996.       YI=Y2(I)
  5997.       ZI=Z2(I)
  5998.       X2(K)=XI*XX+YI*XY+ZI*XZ+XS
  5999.       Y2(K)=XI*YX+YI*YY+ZI*YZ+YS
  6000.       Z2(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  6001.       BI(K)=BI(I)
  6002.       ITAG(K)=ITAG(I)
  6003.       IF(ITAG(I).NE.0)ITAG(K)=ITAG(I)+ITGI
  6004. 1     CONTINUE
  6005.       I1=N+1
  6006.       N=K
  6007. 2     CONTINUE
  6008. 3     IF (M.LT.M2) GO TO 6
  6009.       I1=M2
  6010.       K=M
  6011.       LDI=LD+1
  6012.       IF (NRPT.EQ.0) K=M1
  6013.       DO 5 II=1,NRP
  6014.       DO 4 I=I1,M
  6015.       K=K+1
  6016.       IR=LDI-I
  6017.       KR=LDI-K
  6018.       XI=X(IR)
  6019.       YI=Y(IR)
  6020.       ZI=Z(IR)
  6021.       X(KR)=XI*XX+YI*XY+ZI*XZ+XS
  6022.       Y(KR)=XI*YX+YI*YY+ZI*YZ+YS
  6023.       Z(KR)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  6024.       XI=T1X(IR)
  6025.       YI=T1Y(IR)
  6026.       ZI=T1Z(IR)
  6027.       T1X(KR)=XI*XX+YI*XY+ZI*XZ
  6028.       T1Y(KR)=XI*YX+YI*YY+ZI*YZ
  6029.       T1Z(KR)=XI*ZX+YI*ZY+ZI*ZZ
  6030.       XI=T2X(IR)
  6031.       YI=T2Y(IR)
  6032.       ZI=T2Z(IR)
  6033.       T2X(KR)=XI*XX+YI*XY+ZI*XZ
  6034.       T2Y(KR)=XI*YX+YI*YY+ZI*YZ
  6035.       T2Z(KR)=XI*ZX+YI*ZY+ZI*ZZ
  6036.       SALP(KR)=SALP(IR)
  6037. 4     BI(KR)=BI(IR)
  6038.       I1=M+1
  6039. 5     M=K
  6040. 6     IF ((NRPT.EQ.0).AND.(IX.EQ.1)) RETURN
  6041.       NP=N
  6042.       MP=M
  6043.       IPSYM=0
  6044.       RETURN
  6045.       END
  6046.          
  6047.       SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ)
  6048. C ***
  6049. C     DOUBLE PRECISION 6/4/85
  6050. C
  6051.       INCLUDE 'NEC2DPAR.INC'
  6052.       IMPLICIT REAL*8(A-H,O-Z)
  6053. C ***
  6054. C
  6055. C     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
  6056. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
  6057. C
  6058.       COMPLEX*16 EX,EY,EZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC
  6059.      1,EYC,EZC,ZRATI,ZRATI2,T1,FRATI
  6060.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  6061.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  6062.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  6063.      &IPSYM
  6064.       COMMON /ANGL/ SALP(MAXSEG)
  6065.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  6066.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  6067.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  6068.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  6069.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  6070.      1IPERF,T1,T2
  6071.       DIMENSION CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1),
  6072.      1T2Z(1)
  6073.       EQUIVALENCE (CAB,ALP), (SAB,BET)
  6074.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  6075.      12), (T2Z,ITAG)
  6076. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  6077. C    1J,IND1), (T2ZJ,IND2)
  6078.       EX=(0.,0.)
  6079.       EY=(0.,0.)
  6080.       EZ=(0.,0.)
  6081.       AX=0.
  6082.       IF (N.EQ.0) GO TO 20
  6083.       DO 1 I=1,N
  6084.       XJ=XOB-X(I)
  6085.       YJ=YOB-Y(I)
  6086.       ZJ=ZOB-Z(I)
  6087.       ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
  6088.       IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1
  6089.       ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
  6090.       XJ=BI(I)
  6091.       IF (ZP.GT.0.9*XJ*XJ) GO TO 1
  6092.       AX=XJ
  6093.       GO TO 2
  6094. 1     CONTINUE
  6095. 2     DO 19 I=1,N
  6096.       S=SI(I)
  6097.       B=BI(I)
  6098.       XJ=X(I)
  6099.       YJ=Y(I)
  6100.       ZJ=Z(I)
  6101.       CABJ=CAB(I)
  6102.       SABJ=SAB(I)
  6103.       SALPJ=SALP(I)
  6104.       IF (IEXK.EQ.0) GO TO 18
  6105.       IPR=ICON1(I)
  6106.       IF (IPR) 3,8,4
  6107. 3     IPR=-IPR
  6108.       IF (-ICON1(IPR).NE.I) GO TO 9
  6109.       GO TO 6
  6110. 4     IF (IPR.NE.I) GO TO 5
  6111.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 9
  6112.       GO TO 7
  6113. 5     IF (ICON2(IPR).NE.I) GO TO 9
  6114. 6     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  6115.       IF (XI.LT.0.999999D+0) GO TO 9
  6116.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 9
  6117. 7     IND1=0
  6118.       GO TO 10
  6119. 8     IND1=1
  6120.       GO TO 10
  6121. 9     IND1=2
  6122. 10    IPR=ICON2(I)
  6123.       IF (IPR) 11,16,12
  6124. 11    IPR=-IPR
  6125.       IF (-ICON2(IPR).NE.I) GO TO 17
  6126.       GO TO 14
  6127. 12    IF (IPR.NE.I) GO TO 13
  6128.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 17
  6129.       GO TO 15
  6130. 13    IF (ICON1(IPR).NE.I) GO TO 17
  6131. 14    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  6132.       IF (XI.LT.0.999999D+0) GO TO 17
  6133.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 17
  6134. 15    IND2=0
  6135.       GO TO 18
  6136. 16    IND2=1
  6137.       GO TO 18
  6138. 17    IND2=2
  6139. 18    CONTINUE
  6140.       CALL EFLD (XOB,YOB,ZOB,AX,1)
  6141.       ACX=DCMPLX(AIR(I),AII(I))
  6142.       BCX=DCMPLX(BIR(I),BII(I))
  6143.       CCX=DCMPLX(CIR(I),CII(I))
  6144.       EX=EX+EXK*ACX+EXS*BCX+EXC*CCX
  6145.       EY=EY+EYK*ACX+EYS*BCX+EYC*CCX
  6146. 19    EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX
  6147.       IF (M.EQ.0) RETURN
  6148. 20    JC=N
  6149.       JL=LD+1
  6150.       DO 21 I=1,M
  6151.       JL=JL-1
  6152.       S=BI(JL)
  6153.       XJ=X(JL)
  6154.       YJ=Y(JL)
  6155.       ZJ=Z(JL)
  6156.       T1XJ=T1X(JL)
  6157.       T1YJ=T1Y(JL)
  6158.       T1ZJ=T1Z(JL)
  6159.       T2XJ=T2X(JL)
  6160.       T2YJ=T2Y(JL)
  6161.       T2ZJ=T2Z(JL)
  6162.       JC=JC+3
  6163.       ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
  6164.       BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
  6165.       DO 21 IP=1,KSYMP
  6166.       IPGND=IP
  6167.       CALL UNERE (XOB,YOB,ZOB)
  6168.       EX=EX+ACX*EXK+BCX*EXS
  6169.       EY=EY+ACX*EYK+BCX*EYS
  6170. 21    EZ=EZ+ACX*EZK+BCX*EZS
  6171.       RETURN
  6172.       END
  6173.       SUBROUTINE NETWK (CM,CMB,CMC,CMD,IP,EINC)
  6174. C ***
  6175. C     DOUBLE PRECISION 6/4/85
  6176. C
  6177.       INCLUDE 'NEC2DPAR.INC'
  6178.       IMPLICIT REAL*8(A-H,O-Z)
  6179. C ***
  6180. C
  6181. C     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
  6182. C     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
  6183. C     PRESENT.
  6184. C
  6185.       COMPLEX*16 CMN,RHNT,YMIT,RHS,ZPED,EINC,VSANT,VLT,CUR,VSRC,RHNX
  6186.      1,VQD,VQDS,CUX,CM,CMB,CMC,CMD
  6187.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  6188.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  6189.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  6190.      &IPSYM
  6191.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  6192.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  6193.       COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
  6194.      130),NVQD,NSANT,NQDS
  6195.       COMMON /NETCX/ ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,MASY
  6196.      1M,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),X22R(30)
  6197.      2,X22I(30),NTYP(30)
  6198.       DIMENSION EINC(1), IP(1),CM(1),CMB(1),CMC(1),CMD(1)
  6199.       DIMENSION CMN(30,30), RHNT(30), IPNT(30), NTEQA(30), NTSCA(30), RH
  6200.      1S(3*MAXSEG), VSRC(30), RHNX(30)
  6201.       DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D+0/
  6202.       NEQZ2=NEQ2
  6203.       IF(NEQZ2.EQ.0)NEQZ2=1
  6204.       PIN=0.
  6205.       PNLS=0.
  6206.       NEQT=NEQ+NEQ2
  6207.       IF (NTSOL.NE.0) GO TO 42
  6208.       NOP=NEQ/NPEQ
  6209.       IF (MASYM.EQ.0) GO TO 14
  6210. C
  6211. C     COMPUTE RELATIVE MATRIX ASYMMETRY
  6212. C
  6213.       IROW1=0
  6214.       IF (NONET.EQ.0) GO TO 5
  6215.       DO 4 I=1,NONET
  6216.       NSEG1=ISEG1(I)
  6217.       DO 3 ISC1=1,2
  6218.       IF (IROW1.EQ.0) GO TO 2
  6219.       DO 1 J=1,IROW1
  6220.       IF (NSEG1.EQ.IPNT(J)) GO TO 3
  6221. 1     CONTINUE
  6222. 2     IROW1=IROW1+1
  6223.       IPNT(IROW1)=NSEG1
  6224. 3     NSEG1=ISEG2(I)
  6225. 4     CONTINUE
  6226. 5     IF (NSANT.EQ.0) GO TO 9
  6227.       DO 8 I=1,NSANT
  6228.       NSEG1=ISANT(I)
  6229.       IF (IROW1.EQ.0) GO TO 7
  6230.       DO 6 J=1,IROW1
  6231.       IF (NSEG1.EQ.IPNT(J)) GO TO 8
  6232. 6     CONTINUE
  6233. 7     IROW1=IROW1+1
  6234.       IPNT(IROW1)=NSEG1
  6235. 8     CONTINUE
  6236. 9     IF (IROW1.LT.NDIMNP) GO TO 10
  6237.       WRITE(3,59)
  6238.       STOP
  6239. 10    IF (IROW1.LT.2) GO TO 14
  6240.       DO 12 I=1,IROW1
  6241.       ISC1=IPNT(I)
  6242.       ASM=SI(ISC1)
  6243.       DO 11 J=1,NEQT
  6244. 11    RHS(J)=(0.,0.)
  6245.       RHS(ISC1)=(1.,0.)
  6246.       CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)
  6247.       CALL CABC (RHS)
  6248.       DO 12 J=1,IROW1
  6249.       ISC1=IPNT(J)
  6250. 12    CMN(J,I)=RHS(ISC1)/ASM
  6251.       ASM=0.
  6252.       ASA=0.
  6253.       DO 13 I=2,IROW1
  6254.       ISC1=I-1
  6255.       DO 13 J=1,ISC1
  6256.       CUX=CMN(I,J)
  6257.       PWR=ABS((CUX-CMN(J,I))/CUX)
  6258.       ASA=ASA+PWR*PWR
  6259.       IF (PWR.LT.ASM) GO TO 13
  6260.       ASM=PWR
  6261.       NTEQ=IPNT(I)
  6262.       NTSC=IPNT(J)
  6263. 13    CONTINUE
  6264.       ASA=SQRT(ASA*2./DFLOAT(IROW1*(IROW1-1)))
  6265.       WRITE(3,58)  ASM,NTEQ,NTSC,ASA
  6266. 14    IF (NONET.EQ.0) GO TO 48
  6267. C
  6268. C     SOLUTION OF NETWORK EQUATIONS
  6269. C
  6270.       DO 15 I=1,NDIMN
  6271.       RHNX(I)=(0.,0.)
  6272.       DO 15 J=1,NDIMN
  6273. 15    CMN(I,J)=(0.,0.)
  6274.       NTEQ=0
  6275.       NTSC=0
  6276. C
  6277. C     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
  6278. C     SEGMENTS.
  6279. C
  6280.       DO 38 J=1,NONET
  6281.       NSEG1=ISEG1(J)
  6282.       NSEG2=ISEG2(J)
  6283.       IF (NTYP(J).GT.1) GO TO 16
  6284.       Y11R=X11R(J)
  6285.       Y11I=X11I(J)
  6286.       Y12R=X12R(J)
  6287.       Y12I=X12I(J)
  6288.       Y22R=X22R(J)
  6289.       Y22I=X22I(J)
  6290.       GO TO 17
  6291. 16    Y22R=TP*X11I(J)/WLAM
  6292.       Y12R=0.
  6293.       Y12I=1./(X11R(J)*SIN(Y22R))
  6294.       Y11R=X12R(J)
  6295.       Y11I=-Y12I*COS(Y22R)
  6296.       Y22R=X22R(J)
  6297.       Y22I=Y11I+X22I(J)
  6298.       Y11I=Y11I+X12I(J)
  6299.       IF (NTYP(J).EQ.2) GO TO 17
  6300.       Y12R=-Y12R
  6301.       Y12I=-Y12I
  6302. 17    IF (NSANT.EQ.0) GO TO 19
  6303.       DO 18 I=1,NSANT
  6304.       IF (NSEG1.NE.ISANT(I)) GO TO 18
  6305.       ISC1=I
  6306.       GO TO 22
  6307. 18    CONTINUE
  6308. 19    ISC1=0
  6309.       IF (NTEQ.EQ.0) GO TO 21
  6310.       DO 20 I=1,NTEQ
  6311.       IF (NSEG1.NE.NTEQA(I)) GO TO 20
  6312.       IROW1=I
  6313.       GO TO 25
  6314. 20    CONTINUE
  6315. 21    NTEQ=NTEQ+1
  6316.       IROW1=NTEQ
  6317.       NTEQA(NTEQ)=NSEG1
  6318.       GO TO 25
  6319. 22    IF (NTSC.EQ.0) GO TO 24
  6320.       DO 23 I=1,NTSC
  6321.       IF (NSEG1.NE.NTSCA(I)) GO TO 23
  6322.       IROW1=NDIMNP-I
  6323.       GO TO 25
  6324. 23    CONTINUE
  6325. 24    NTSC=NTSC+1
  6326.       IROW1=NDIMNP-NTSC
  6327.       NTSCA(NTSC)=NSEG1
  6328.       VSRC(NTSC)=VSANT(ISC1)
  6329. 25    IF (NSANT.EQ.0) GO TO 27
  6330.       DO 26 I=1,NSANT
  6331.       IF (NSEG2.NE.ISANT(I)) GO TO 26
  6332.       ISC2=I
  6333.       GO TO 30
  6334. 26    CONTINUE
  6335. 27    ISC2=0
  6336.       IF (NTEQ.EQ.0) GO TO 29
  6337.       DO 28 I=1,NTEQ
  6338.       IF (NSEG2.NE.NTEQA(I)) GO TO 28
  6339.       IROW2=I
  6340.       GO TO 33
  6341. 28    CONTINUE
  6342. 29    NTEQ=NTEQ+1
  6343.       IROW2=NTEQ
  6344.       NTEQA(NTEQ)=NSEG2
  6345.       GO TO 33
  6346. 30    IF (NTSC.EQ.0) GO TO 32
  6347.       DO 31 I=1,NTSC
  6348.       IF (NSEG2.NE.NTSCA(I)) GO TO 31
  6349.       IROW2=NDIMNP-I
  6350.       GO TO 33
  6351. 31    CONTINUE
  6352. 32    NTSC=NTSC+1
  6353.       IROW2=NDIMNP-NTSC
  6354.       NTSCA(NTSC)=NSEG2
  6355.       VSRC(NTSC)=VSANT(ISC2)
  6356. 33    IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34
  6357.       WRITE(3,59)
  6358.       STOP
  6359. C
  6360. C     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
  6361. C     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
  6362. C
  6363. 34    IF (ISC1.NE.0) GO TO 35
  6364.       CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-DCMPLX(Y11R,Y11I)*SI(NSEG1)
  6365.       CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-DCMPLX(Y12R,Y12I)*SI(NSEG1)
  6366.       GO TO 36
  6367. 35    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM
  6368.       RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM
  6369. 36    IF (ISC2.NE.0) GO TO 37
  6370.       CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-DCMPLX(Y22R,Y22I)*SI(NSEG2)
  6371.       CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-DCMPLX(Y12R,Y12I)*SI(NSEG2)
  6372.       GO TO 38
  6373. 37    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM
  6374.       RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM
  6375. 38    CONTINUE
  6376. C
  6377. C     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
  6378. C     MATRIX
  6379. C
  6380.       DO 41 I=1,NTEQ
  6381.       DO 39 J=1,NEQT
  6382. 39    RHS(J)=(0.,0.)
  6383.       IROW1=NTEQA(I)
  6384.       RHS(IROW1)=(1.,0.)
  6385.       CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)
  6386.       CALL CABC (RHS)
  6387.       DO 40 J=1,NTEQ
  6388.       IROW1=NTEQA(J)
  6389. 40    CMN(I,J)=CMN(I,J)+RHS(IROW1)
  6390. 41    CONTINUE
  6391. C
  6392. C     FACTOR NETWORK EQUATION MATRIX
  6393. C
  6394.       CALL FACTR (NTEQ,CMN,IPNT,NDIMN)
  6395. C
  6396. C     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
  6397. C     INTERACTIONS
  6398. C
  6399. 42    IF (NONET.EQ.0) GO TO 48
  6400.       DO 43 I=1,NEQT
  6401. 43    RHS(I)=EINC(I)
  6402.       CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)
  6403.       CALL CABC (RHS)
  6404.       DO 44 I=1,NTEQ
  6405.       IROW1=NTEQA(I)
  6406. 44    RHNT(I)=RHNX(I)+RHS(IROW1)
  6407. C
  6408. C     SOLVE NETWORK EQUATIONS
  6409. C
  6410.       CALL SOLVE (NTEQ,CMN,IPNT,RHNT,NDIMN)
  6411. C
  6412. C     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
  6413. C     STRUCTURE AND SOLVE FOR INDUCED CURRENT
  6414. C
  6415.       DO 45 I=1,NTEQ
  6416.       IROW1=NTEQA(I)
  6417. 45    EINC(IROW1)=EINC(IROW1)-RHNT(I)
  6418.       CALL SOLGF (CM,CMB,CMC,CMD,EINC,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)
  6419.       CALL CABC (EINC)
  6420.       IF (NPRINT.EQ.0) WRITE(3,61)
  6421.       IF (NPRINT.EQ.0) WRITE(3,60)
  6422.       DO 46 I=1,NTEQ
  6423.       IROW1=NTEQA(I)
  6424.       VLT=RHNT(I)*SI(IROW1)*WLAM
  6425.       CUX=EINC(IROW1)*WLAM
  6426.       YMIT=CUX/VLT
  6427.       ZPED=VLT/CUX
  6428.       IROW2=ITAG(IROW1)
  6429.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  6430.       PNLS=PNLS-PWR
  6431. 46    IF (NPRINT.EQ.0) WRITE(3,62)  IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR
  6432.       IF (NTSC.EQ.0) GO TO 49
  6433.       DO 47 I=1,NTSC
  6434.       IROW1=NTSCA(I)
  6435.       VLT=VSRC(I)
  6436.       CUX=EINC(IROW1)*WLAM
  6437.       YMIT=CUX/VLT
  6438.       ZPED=VLT/CUX
  6439.       IROW2=ITAG(IROW1)
  6440.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  6441.       PNLS=PNLS-PWR
  6442. 47    IF (NPRINT.EQ.0) WRITE(3,62)  IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR
  6443.       GO TO 49
  6444. C
  6445. C     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
  6446. C
  6447. 48    CALL SOLGF (CM,CMB,CMC,CMD,EINC,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)
  6448.       CALL CABC (EINC)
  6449.       NTSC=0
  6450. 49    IF (NSANT+NVQD.EQ.0) RETURN
  6451.       WRITE(3,63)
  6452.       WRITE(3,60)
  6453.       IF (NSANT.EQ.0) GO TO 56
  6454.       DO 55 I=1,NSANT
  6455.       ISC1=ISANT(I)
  6456.       VLT=VSANT(I)
  6457.       IF (NTSC.EQ.0) GO TO 51
  6458.       DO 50 J=1,NTSC
  6459.       IF (NTSCA(J).EQ.ISC1) GO TO 52
  6460. 50    CONTINUE
  6461. 51    CUX=EINC(ISC1)*WLAM
  6462.       IROW1=0
  6463.       GO TO 54
  6464. 52    IROW1=NDIMNP-J
  6465.       CUX=RHNX(IROW1)
  6466.       DO 53 J=1,NTEQ
  6467. 53    CUX=CUX-CMN(J,IROW1)*RHNT(J)
  6468.       CUX=(EINC(ISC1)+CUX)*WLAM
  6469. 54    YMIT=CUX/VLT
  6470.       ZPED=VLT/CUX
  6471.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  6472.       PIN=PIN+PWR
  6473.       IF (IROW1.NE.0) PNLS=PNLS+PWR
  6474.       IROW2=ITAG(ISC1)
  6475. 55    WRITE(3,62)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
  6476. 56    IF (NVQD.EQ.0) RETURN
  6477.       DO 57 I=1,NVQD
  6478.       ISC1=IVQD(I)
  6479.       VLT=VQD(I)
  6480.       CUX=DCMPLX(AIR(ISC1),AII(ISC1))
  6481.       YMIT=DCMPLX(BIR(ISC1),BII(ISC1))
  6482.       ZPED=DCMPLX(CIR(ISC1),CII(ISC1))
  6483.       PWR=SI(ISC1)*TP*.5
  6484.       CUX=(CUX-YMIT*SIN(PWR)+ZPED*COS(PWR))*WLAM
  6485.       YMIT=CUX/VLT
  6486.       ZPED=VLT/CUX
  6487.       PWR=.5*DREAL(VLT*DCONJG(CUX))
  6488.       PIN=PIN+PWR
  6489.       IROW2=ITAG(ISC1)
  6490. 57    WRITE(3,64)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
  6491.       RETURN
  6492. C
  6493. 58    FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT,
  6494.      121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,4H AND,I5,/,
  6495.      23X,25HRMS RELATIVE ASYMMETRY IS,E10.3)
  6496. 59    FORMAT (1X,44HERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL)
  6497. 60    FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT (
  6498.      1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/,
  6499.      23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X,
  6500.      37H(WATTS))
  6501. 61    FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN
  6502.      1ECTION POINTS - - -)
  6503. 62    FORMAT (2(1X,I5),1P,9E12.5)
  6504. 63    FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -)
  6505. 64    FORMAT (1X,I5,2H *,I4,1P,9E12.5)
  6506.       END
  6507.       SUBROUTINE NFPAT
  6508. C ***
  6509. C     DOUBLE PRECISION 6/4/85
  6510. C
  6511.       INCLUDE 'NEC2DPAR.INC'
  6512.       IMPLICIT REAL*8(A-H,O-Z)
  6513. C ***
  6514. C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
  6515.       COMPLEX*16 EX,EY,EZ
  6516.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  6517.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  6518.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  6519.      &IPSYM
  6520.       COMMON /FPAT/ NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,GN
  6521.      1OR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,NRX,NRY
  6522.      2,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
  6523. C***
  6524.       COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  6525. C***
  6526.       DATA TA/1.745329252D-02/
  6527.       IF (NFEH.EQ.1) GO TO 1
  6528.       WRITE(3,10)
  6529.       GO TO 2
  6530. 1     WRITE(3,12)
  6531. 2     ZNRT=ZNR-DZNR
  6532.       DO 9 I=1,NRZ
  6533.       ZNRT=ZNRT+DZNR
  6534.       IF (NEAR.EQ.0) GO TO 3
  6535.       CTH=COS(TA*ZNRT)
  6536.       STH=SIN(TA*ZNRT)
  6537. 3     YNRT=YNR-DYNR
  6538.       DO 9 J=1,NRY
  6539.       YNRT=YNRT+DYNR
  6540.       IF (NEAR.EQ.0) GO TO 4
  6541.       CPH=COS(TA*YNRT)
  6542.       SPH=SIN(TA*YNRT)
  6543. 4     XNRT=XNR-DXNR
  6544.       DO 9 KK=1,NRX
  6545.       XNRT=XNRT+DXNR
  6546.       IF (NEAR.EQ.0) GO TO 5
  6547.       XOB=XNRT*STH*CPH
  6548.       YOB=XNRT*STH*SPH
  6549.       ZOB=XNRT*CTH
  6550.       GO TO 6
  6551. 5     XOB=XNRT
  6552.       YOB=YNRT
  6553.       ZOB=ZNRT
  6554. 6     TMP1=XOB/WLAM
  6555.       TMP2=YOB/WLAM
  6556.       TMP3=ZOB/WLAM
  6557.       IF (NFEH.EQ.1) GO TO 7
  6558.       CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ)
  6559.       GO TO 8
  6560. 7     CALL NHFLD (TMP1,TMP2,TMP3,EX,EY,EZ)
  6561. 8     TMP1=ABS(EX)
  6562.       TMP2=CANG(EX)
  6563.       TMP3=ABS(EY)
  6564.       TMP4=CANG(EY)
  6565.       TMP5=ABS(EZ)
  6566.       TMP6=CANG(EZ)
  6567.       WRITE(3,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
  6568. C***
  6569.       IF(IPLP1 .NE. 2) GO TO 9
  6570.       GO TO (14,15,16),IPLP4
  6571. 14    XXX=XOB
  6572.       GO TO 17
  6573. 15    XXX=YOB
  6574.       GO TO 17
  6575. 16    XXX=ZOB
  6576. 17    CONTINUE
  6577.       IF(IPLP2 .NE. 2) GO TO 13
  6578.       IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,TMP1,TMP2
  6579.       IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,TMP3,TMP4
  6580.       IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,TMP5,TMP6
  6581.       IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
  6582.       GO TO 9
  6583. 13    IF(IPLP2 .NE. 1) GO TO 9
  6584.       IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,EX
  6585.       IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,EY
  6586.       IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,EZ
  6587.       IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZ
  6588. C***
  6589. 9     CONTINUE
  6590.       RETURN
  6591. C
  6592. 10    FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H-  L
  6593.      1OCATION  -,21X,8H-  EX  -,15X,8H-  EY  -,15X,8H-  EZ  -,/,8X,1HX,1
  6594.      20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS
  6595.      3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS,
  6596.      48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3
  6597.      5X,7HDEGREES)
  6598. 11    FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2))
  6599. 12    FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H-  L
  6600.      1OCATION  -,21X,8H-  HX  -,15X,8H-  HY  -,15X,8H-  HZ  -,/,8X,1HX,1
  6601.      20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS
  6602.      3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS,
  6603.      49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7
  6604.      5HDEGREES)
  6605.       END
  6606.       SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ)
  6607. C
  6608. C     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
  6609. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
  6610. C
  6611.       INCLUDE 'NEC2DPAR.INC'
  6612.       IMPLICIT REAL*8(A-H,O-Z)
  6613.       COMPLEX*16 HX,HY,HZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC,
  6614.      &EYC,EZC
  6615. C***************************************
  6616.       COMPLEX*16 ZRATI,ZRATI2,FRATI,T1,CON
  6617.       COMPLEX*16 EXPX,EXMX,EXPY,EXMY,EXPZ,EXMZ
  6618.       COMPLEX*16 EYPX,EYMX,EYPY,EYMY,EYPZ,EYMZ
  6619.       COMPLEX*16 EZPX,EZMX,EZPY,EZMY,EZPZ,EZMZ
  6620.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  6621.      1IPERF,T1,T2
  6622. C***************************************
  6623.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  6624.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  6625.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  6626.      &IPSYM
  6627.       COMMON /ANGL/ SALP(MAXSEG)
  6628.       COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
  6629.      &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
  6630.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  6631.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  6632.       DIMENSION CAB(1), SAB(1)
  6633.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1), Y
  6634.      1S(1), ZS(1)
  6635.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  6636.      12), (T2Z,ITAG), (XS,X), (YS,Y), (ZS,Z)
  6637. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  6638. C    1J,IND1), (T2ZJ,IND2)
  6639.       EQUIVALENCE (CAB,ALP), (SAB,BET)
  6640. C***************************************
  6641.       IF (IPERF.EQ.2) GO TO 6
  6642. C***************************************
  6643.       HX=(0.,0.)
  6644.       HY=(0.,0.)
  6645.       HZ=(0.,0.)
  6646.       AX=0.
  6647.       IF (N.EQ.0) GO TO 4
  6648.       DO 1 I=1,N
  6649.       XJ=XOB-X(I)
  6650.       YJ=YOB-Y(I)
  6651.       ZJ=ZOB-Z(I)
  6652.       ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
  6653.       IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1
  6654.       ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
  6655.       XJ=BI(I)
  6656.       IF (ZP.GT.0.9*XJ*XJ) GO TO 1
  6657.       AX=XJ
  6658.       GO TO 2
  6659. 1     CONTINUE
  6660. 2     DO 3 I=1,N
  6661.       S=SI(I)
  6662.       B=BI(I)
  6663.       XJ=X(I)
  6664.       YJ=Y(I)
  6665.       ZJ=Z(I)
  6666.       CABJ=CAB(I)
  6667.       SABJ=SAB(I)
  6668.       SALPJ=SALP(I)
  6669.       CALL HSFLD (XOB,YOB,ZOB,AX)
  6670.       ACX=DCMPLX(AIR(I),AII(I))
  6671.       BCX=DCMPLX(BIR(I),BII(I))
  6672.       CCX=DCMPLX(CIR(I),CII(I))
  6673.       HX=HX+EXK*ACX+EXS*BCX+EXC*CCX
  6674.       HY=HY+EYK*ACX+EYS*BCX+EYC*CCX
  6675. 3     HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX
  6676.       IF (M.EQ.0) RETURN
  6677. 4     JC=N
  6678.       JL=LD+1
  6679.       DO 5 I=1,M
  6680.       JL=JL-1
  6681.       S=BI(JL)
  6682.       XJ=X(JL)
  6683.       YJ=Y(JL)
  6684.       ZJ=Z(JL)
  6685.       T1XJ=T1X(JL)
  6686.       T1YJ=T1Y(JL)
  6687.       T1ZJ=T1Z(JL)
  6688.       T2XJ=T2X(JL)
  6689.       T2YJ=T2Y(JL)
  6690.       T2ZJ=T2Z(JL)
  6691.       CALL HINTG (XOB,YOB,ZOB)
  6692.       JC=JC+3
  6693.       ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
  6694.       BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
  6695.       HX=HX+ACX*EXK+BCX*EXS
  6696.       HY=HY+ACX*EYK+BCX*EYS
  6697. 5     HZ=HZ+ACX*EZK+BCX*EZS
  6698.       RETURN
  6699. C
  6700. C     GET H BY FINITE DIFFERENCE OF E FOR SOMMERFELD GROUND
  6701. C     CON=j/(2*pi*eta)
  6702. C     DELT is the increment for getting central differences
  6703. C
  6704. 6     DELT=1.E-3
  6705.       CON=(0.,4.2246E-4)
  6706.       CALL NEFLD (XOB+DELT,YOB,ZOB,EXPX,EYPX,EZPX)
  6707.       CALL NEFLD (XOB-DELT,YOB,ZOB,EXMX,EYMX,EZMX)
  6708.       CALL NEFLD (XOB,YOB+DELT,ZOB,EXPY,EYPY,EZPY)
  6709.       CALL NEFLD (XOB,YOB-DELT,ZOB,EXMY,EYMY,EZMY)
  6710.       CALL NEFLD (XOB,YOB,ZOB+DELT,EXPZ,EYPZ,EZPZ)
  6711.       CALL NEFLD (XOB,YOB,ZOB-DELT,EXMZ,EYMZ,EZMZ)
  6712.       HX=CON*(EZPY-EZMY-EYPZ+EYMZ)/(2.*DELT)
  6713.       HY=CON*(EXPZ-EXMZ-EZPX+EZMX)/(2.*DELT)
  6714.       HZ=CON*(EYPX-EYMX-EXPY+EXMY)/(2.*DELT)
  6715.       RETURN
  6716.       END
  6717.       SUBROUTINE PATCH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4)
  6718. C ***
  6719. C     DOUBLE PRECISION 6/4/85
  6720. C
  6721.       INCLUDE 'NEC2DPAR.INC'
  6722.       IMPLICIT REAL*8(A-H,O-Z)
  6723. C ***
  6724. C     PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA
  6725.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  6726.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  6727.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  6728.      &IPSYM
  6729.       COMMON /ANGL/ SALP(MAXSEG)
  6730.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  6731.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  6732.      12), (T2Z,ITAG)
  6733. C     NEW PATCHES.  FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY)
  6734. C     ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL.
  6735. C     FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH
  6736. C     NX BY NY RECTANGULAR PATCHES.
  6737.       M=M+1
  6738.       MI=LD+1-M
  6739.       NTP=NY
  6740.       IF (NX.GT.0) NTP=2
  6741.       IF (NTP.GT.1) GO TO 2
  6742.       X(MI)=X1
  6743.       Y(MI)=Y1
  6744.       Z(MI)=Z1
  6745.       BI(MI)=Z2
  6746.       ZNV=COS(X2)
  6747.       XNV=ZNV*COS(Y2)
  6748.       YNV=ZNV*SIN(Y2)
  6749.       ZNV=SIN(X2)
  6750.       XA=SQRT(XNV*XNV+YNV*YNV)
  6751.       IF (XA.LT.1.D-6) GO TO 1
  6752.       T1X(MI)=-YNV/XA
  6753.       T1Y(MI)=XNV/XA
  6754.       T1Z(MI)=0.
  6755.       GO TO 6
  6756. 1     T1X(MI)=1.
  6757.       T1Y(MI)=0.
  6758.       T1Z(MI)=0.
  6759.       GO TO 6
  6760. 2     S1X=X2-X1
  6761.       S1Y=Y2-Y1
  6762.       S1Z=Z2-Z1
  6763.       S2X=X3-X2
  6764.       S2Y=Y3-Y2
  6765.       S2Z=Z3-Z2
  6766.       IF (NX.EQ.0) GO TO 3
  6767.       S1X=S1X/NX
  6768.       S1Y=S1Y/NX
  6769.       S1Z=S1Z/NX
  6770.       S2X=S2X/NY
  6771.       S2Y=S2Y/NY
  6772.       S2Z=S2Z/NY
  6773. 3     XNV=S1Y*S2Z-S1Z*S2Y
  6774.       YNV=S1Z*S2X-S1X*S2Z
  6775.       ZNV=S1X*S2Y-S1Y*S2X
  6776.       XA=SQRT(XNV*XNV+YNV*YNV+ZNV*ZNV)
  6777.       XNV=XNV/XA
  6778.       YNV=YNV/XA
  6779.       ZNV=ZNV/XA
  6780.       XST=SQRT(S1X*S1X+S1Y*S1Y+S1Z*S1Z)
  6781.       T1X(MI)=S1X/XST
  6782.       T1Y(MI)=S1Y/XST
  6783.       T1Z(MI)=S1Z/XST
  6784.       IF (NTP.GT.2) GO TO 4
  6785.       X(MI)=X1+.5*(S1X+S2X)
  6786.       Y(MI)=Y1+.5*(S1Y+S2Y)
  6787.       Z(MI)=Z1+.5*(S1Z+S2Z)
  6788.       BI(MI)=XA
  6789.       GO TO 6
  6790. 4     IF (NTP.EQ.4) GO TO 5
  6791.       X(MI)=(X1+X2+X3)/3.
  6792.       Y(MI)=(Y1+Y2+Y3)/3.
  6793.       Z(MI)=(Z1+Z2+Z3)/3.
  6794.       BI(MI)=.5*XA
  6795.       GO TO 6
  6796. 5     S1X=X3-X1
  6797.       S1Y=Y3-Y1
  6798.       S1Z=Z3-Z1
  6799.       S2X=X4-X1
  6800.       S2Y=Y4-Y1
  6801.       S2Z=Z4-Z1
  6802.       XN2=S1Y*S2Z-S1Z*S2Y
  6803.       YN2=S1Z*S2X-S1X*S2Z
  6804.       ZN2=S1X*S2Y-S1Y*S2X
  6805.       XST=SQRT(XN2*XN2+YN2*YN2+ZN2*ZN2)
  6806.       SALPN=1./(3.*(XA+XST))
  6807.       X(MI)=(XA*(X1+X2+X3)+XST*(X1+X3+X4))*SALPN
  6808.       Y(MI)=(XA*(Y1+Y2+Y3)+XST*(Y1+Y3+Y4))*SALPN
  6809.       Z(MI)=(XA*(Z1+Z2+Z3)+XST*(Z1+Z3+Z4))*SALPN
  6810.       BI(MI)=.5*(XA+XST)
  6811.       S1X=(XNV*XN2+YNV*YN2+ZNV*ZN2)/XST
  6812.       IF (S1X.GT.0.9998) GO TO 6
  6813.       WRITE(3,14)
  6814.       STOP
  6815. 6     T2X(MI)=YNV*T1Z(MI)-ZNV*T1Y(MI)
  6816.       T2Y(MI)=ZNV*T1X(MI)-XNV*T1Z(MI)
  6817.       T2Z(MI)=XNV*T1Y(MI)-YNV*T1X(MI)
  6818.       SALP(MI)=1.
  6819.       IF (NX.EQ.0) GO TO 8
  6820.       M=M+NX*NY-1
  6821.       XN2=X(MI)-S1X-S2X
  6822.       YN2=Y(MI)-S1Y-S2Y
  6823.       ZN2=Z(MI)-S1Z-S2Z
  6824.       XS=T1X(MI)
  6825.       YS=T1Y(MI)
  6826.       ZS=T1Z(MI)
  6827.       XT=T2X(MI)
  6828.       YT=T2Y(MI)
  6829.       ZT=T2Z(MI)
  6830.       MI=MI+1
  6831.       DO 7 IY=1,NY
  6832.       XN2=XN2+S2X
  6833.       YN2=YN2+S2Y
  6834.       ZN2=ZN2+S2Z
  6835.       DO 7 IX=1,NX
  6836.       XST=IX
  6837.       MI=MI-1
  6838.       X(MI)=XN2+XST*S1X
  6839.       Y(MI)=YN2+XST*S1Y
  6840.       Z(MI)=ZN2+XST*S1Z
  6841.       BI(MI)=XA
  6842.       SALP(MI)=1.
  6843.       T1X(MI)=XS
  6844.       T1Y(MI)=YS
  6845.       T1Z(MI)=ZS
  6846.       T2X(MI)=XT
  6847.       T2Y(MI)=YT
  6848. 7     T2Z(MI)=ZT
  6849. 8     IPSYM=0
  6850.       NP=N
  6851.       MP=M
  6852.       RETURN
  6853. C     DIVIDE PATCH FOR WIRE CONNECTION
  6854.       ENTRY SUBPH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4)
  6855.       IF (NY.GT.0) GO TO 10
  6856.       IF (NX.EQ.M) GO TO 10
  6857.       NXP=NX+1
  6858.       IX=LD-M
  6859.       DO 9 IY=NXP,M
  6860.       IX=IX+1
  6861.       NYP=IX-3
  6862.       X(NYP)=X(IX)
  6863.       Y(NYP)=Y(IX)
  6864.       Z(NYP)=Z(IX)
  6865.       BI(NYP)=BI(IX)
  6866.       SALP(NYP)=SALP(IX)
  6867.       T1X(NYP)=T1X(IX)
  6868.       T1Y(NYP)=T1Y(IX)
  6869.       T1Z(NYP)=T1Z(IX)
  6870.       T2X(NYP)=T2X(IX)
  6871.       T2Y(NYP)=T2Y(IX)
  6872. 9     T2Z(NYP)=T2Z(IX)
  6873. 10    MI=LD+1-NX
  6874.       XS=X(MI)
  6875.       YS=Y(MI)
  6876.       ZS=Z(MI)
  6877.       XA=BI(MI)*.25
  6878.       XST=SQRT(XA)*.5
  6879.       S1X=T1X(MI)
  6880.       S1Y=T1Y(MI)
  6881.       S1Z=T1Z(MI)
  6882.       S2X=T2X(MI)
  6883.       S2Y=T2Y(MI)
  6884.       S2Z=T2Z(MI)
  6885.       SALN=SALP(MI)
  6886.       XT=XST
  6887.       YT=XST
  6888.       IF (NY.GT.0) GO TO 11
  6889.       MIA=MI
  6890.       GO TO 12
  6891. 11    M=M+1
  6892.       MP=MP+1
  6893.       MIA=LD+1-M
  6894. 12    DO 13 IX=1,4
  6895.       X(MIA)=XS+XT*S1X+YT*S2X
  6896.       Y(MIA)=YS+XT*S1Y+YT*S2Y
  6897.       Z(MIA)=ZS+XT*S1Z+YT*S2Z
  6898.       BI(MIA)=XA
  6899.       T1X(MIA)=S1X
  6900.       T1Y(MIA)=S1Y
  6901.       T1Z(MIA)=S1Z
  6902.       T2X(MIA)=S2X
  6903.       T2Y(MIA)=S2Y
  6904.       T2Z(MIA)=S2Z
  6905.       SALP(MIA)=SALN
  6906.       IF (IX.EQ.2) YT=-YT
  6907.       IF (IX.EQ.1.OR.IX.EQ.3) XT=-XT
  6908.       MIA=MIA-1
  6909. 13    CONTINUE
  6910.       M=M+3
  6911.       IF (NX.LE.MP) MP=MP+3
  6912.       IF (NY.GT.0) Z(MI)=10000.
  6913.       RETURN
  6914. C
  6915. 14    FORMAT (62H ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN 
  6916.      1A PLANE)
  6917.       END
  6918.       SUBROUTINE PCINT (XI,YI,ZI,CABI,SABI,SALPI,E)
  6919. C ***
  6920. C     DOUBLE PRECISION 6/4/85
  6921. C
  6922.       IMPLICIT REAL*8(A-H,O-Z)
  6923. C ***
  6924. C     INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT
  6925.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,E,E1,E2,E3,E4,E5
  6926.      1,E6,E7,E8,E9
  6927.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  6928.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,PGND
  6929.       DIMENSION E(9)
  6930. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  6931. C    1J,IND1), (T2ZJ,IND2)
  6932.       DATA TPI/6.283185308D+0/,NINT/10/
  6933.       D=SQRT(S)*.5
  6934.       DS=4.*D/DFLOAT(NINT)
  6935.       DA=DS*DS
  6936.       GCON=1./S
  6937.       FCON=1./(2.*TPI*D)
  6938.       XXJ=XJ
  6939.       XYJ=YJ
  6940.       XZJ=ZJ
  6941.       XS=S
  6942.       S=DA
  6943.       S1=D+DS*.5
  6944.       XSS=XJ+S1*(T1XJ+T2XJ)
  6945.       YSS=YJ+S1*(T1YJ+T2YJ)
  6946.       ZSS=ZJ+S1*(T1ZJ+T2ZJ)
  6947.       S1=S1+D
  6948.       S2X=S1
  6949.       E1=(0.,0.)
  6950.       E2=(0.,0.)
  6951.       E3=(0.,0.)
  6952.       E4=(0.,0.)
  6953.       E5=(0.,0.)
  6954.       E6=(0.,0.)
  6955.       E7=(0.,0.)
  6956.       E8=(0.,0.)
  6957.       E9=(0.,0.)
  6958.       DO 1 I1=1,NINT
  6959.       S1=S1-DS
  6960.       S2=S2X
  6961.       XSS=XSS-DS*T1XJ
  6962.       YSS=YSS-DS*T1YJ
  6963.       ZSS=ZSS-DS*T1ZJ
  6964.       XJ=XSS
  6965.       YJ=YSS
  6966.       ZJ=ZSS
  6967.       DO 1 I2=1,NINT
  6968.       S2=S2-DS
  6969.       XJ=XJ-DS*T2XJ
  6970.       YJ=YJ-DS*T2YJ
  6971.       ZJ=ZJ-DS*T2ZJ
  6972.       CALL UNERE (XI,YI,ZI)
  6973.       EXK=EXK*CABI+EYK*SABI+EZK*SALPI
  6974.       EXS=EXS*CABI+EYS*SABI+EZS*SALPI
  6975.       G1=(D+S1)*(D+S2)*GCON
  6976.       G2=(D-S1)*(D+S2)*GCON
  6977.       G3=(D-S1)*(D-S2)*GCON
  6978.       G4=(D+S1)*(D-S2)*GCON
  6979.       F2=(S1*S1+S2*S2)*TPI
  6980.       F1=S1/F2-(G1-G2-G3+G4)*FCON
  6981.       F2=S2/F2-(G1+G2-G3-G4)*FCON
  6982.       E1=E1+EXK*G1
  6983.       E2=E2+EXK*G2
  6984.       E3=E3+EXK*G3
  6985.       E4=E4+EXK*G4
  6986.       E5=E5+EXS*G1
  6987.       E6=E6+EXS*G2
  6988.       E7=E7+EXS*G3
  6989.       E8=E8+EXS*G4
  6990. 1     E9=E9+EXK*F1+EXS*F2
  6991.       E(1)=E1
  6992.       E(2)=E2
  6993.       E(3)=E3
  6994.       E(4)=E4
  6995.       E(5)=E5
  6996.       E(6)=E6
  6997.       E(7)=E7
  6998.       E(8)=E8
  6999.       E(9)=E9
  7000.       XJ=XXJ
  7001.       YJ=XYJ
  7002.       ZJ=XZJ
  7003.       S=XS
  7004.       RETURN
  7005.       END
  7006.       SUBROUTINE PRNT(IN1,IN2,IN3,FL1,FL2,FL3,FL4,FL5,FL6,CTYPE)
  7007. C
  7008. C     Purpose:
  7009. C     PRNT prints the input data for impedance loading, inserting blanks
  7010. C     for numbers that are zero.
  7011. C
  7012. C     INPUT:
  7013. C     IN1-3 = INTEGER VALUES TO BE PRINTED
  7014. C     FL1-6 = REAL VALUES TO BE PRINTED
  7015. C     CTYPE = CHARACTER STRING TO BE PRINTED
  7016. C
  7017.       IMPLICIT REAL*8(A-H,O-Z)
  7018.       CHARACTER CTYPE*(*), CINT(3)*5, CFLT(6)*13
  7019. C
  7020.       DO 1 I=1,3
  7021. 1     CINT(I)='     '
  7022.       IF(IN1.EQ.0.AND.IN2.EQ.0.AND.IN3.EQ.0)THEN
  7023.          CINT(1)='  ALL'
  7024.       ELSE
  7025.          IF(IN1.NE.0)WRITE(CINT(1),90)IN1
  7026.          IF(IN2.NE.0)WRITE(CINT(2),90)IN2
  7027.          IF(IN3.NE.0)WRITE(CINT(3),90)IN3
  7028.       END IF
  7029.       DO 2 I=1,6
  7030. 2     CFLT(I)='     '
  7031.       IF(ABS(FL1).GT.1.E-30)WRITE(CFLT(1),91)FL1
  7032.       IF(ABS(FL2).GT.1.E-30)WRITE(CFLT(2),91)FL2
  7033.       IF(ABS(FL3).GT.1.E-30)WRITE(CFLT(3),91)FL3
  7034.       IF(ABS(FL4).GT.1.E-30)WRITE(CFLT(4),91)FL4
  7035.       IF(ABS(FL5).GT.1.E-30)WRITE(CFLT(5),91)FL5
  7036.       IF(ABS(FL6).GT.1.E-30)WRITE(CFLT(6),91)FL6
  7037.       WRITE(3,92)(CINT(I),I=1,3),(CFLT(I),I=1,6),CTYPE
  7038.       RETURN
  7039. C
  7040. 90    FORMAT(I5)
  7041. 91    FORMAT(1P,E13.4)
  7042. 92    FORMAT(/,3X,3A,3X,6A,3X,A)
  7043.       END
  7044.       SUBROUTINE QDSRC (IS,V,E)
  7045. C ***
  7046. C     DOUBLE PRECISION 6/4/85
  7047. C
  7048.       INCLUDE 'NEC2DPAR.INC'
  7049.       IMPLICIT REAL*8(A-H,O-Z)
  7050. C ***
  7051. C     FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
  7052.       COMPLEX*16 VQDS,CURD,CCJ,V,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  7053.      1,ETK,ETS,ETC,VSANT,VQD,E,ZARRAY
  7054.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  7055.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  7056.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  7057.      &IPSYM
  7058.       COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
  7059.      130),NVQD,NSANT,NQDS
  7060.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  7061.      1CON(10),NPCON
  7062.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  7063.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  7064.       COMMON /ANGL/ SALP(MAXSEG)
  7065.       COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
  7066.       DIMENSION CCJX(2), E(1), CAB(1), SAB(1)
  7067.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  7068.       EQUIVALENCE (CCJ,CCJX), (CAB,ALP), (SAB,BET)
  7069.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  7070.      12), (T2Z,ITAG)
  7071.       DATA TP/6.283185308D+0/,CCJX/0.,-.01666666667D+0/
  7072.       I=ICON1(IS)
  7073.       ICON1(IS)=0
  7074.       CALL TBF (IS,0)
  7075.       ICON1(IS)=I
  7076.       S=SI(IS)*.5
  7077.       CURD=CCJ*V/((LOG(2.*S/BI(IS))-1.)*(BX(JSNO)*COS(TP*S)+CX(JSNO)*SI
  7078.      1N(TP*S))*WLAM)
  7079.       NQDS=NQDS+1
  7080.       VQDS(NQDS)=V
  7081.       IQDS(NQDS)=IS
  7082.       DO 20 JX=1,JSNO
  7083.       J=JCO(JX)
  7084.       S=SI(J)
  7085.       B=BI(J)
  7086.       XJ=X(J)
  7087.       YJ=Y(J)
  7088.       ZJ=Z(J)
  7089.       CABJ=CAB(J)
  7090.       SABJ=SAB(J)
  7091.       SALPJ=SALP(J)
  7092.       IF (IEXK.EQ.0) GO TO 16
  7093.       IPR=ICON1(J)
  7094.       IF (IPR) 1,6,2
  7095. 1     IPR=-IPR
  7096.       IF (-ICON1(IPR).NE.J) GO TO 7
  7097.       GO TO 4
  7098. 2     IF (IPR.NE.J) GO TO 3
  7099.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7
  7100.       GO TO 5
  7101. 3     IF (ICON2(IPR).NE.J) GO TO 7
  7102. 4     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  7103.       IF (XI.LT.0.999999D+0) GO TO 7
  7104.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 7
  7105. 5     IND1=0
  7106.       GO TO 8
  7107. 6     IND1=1
  7108.       GO TO 8
  7109. 7     IND1=2
  7110. 8     IPR=ICON2(J)
  7111.       IF (IPR) 9,14,10
  7112. 9     IPR=-IPR
  7113.       IF (-ICON2(IPR).NE.J) GO TO 15
  7114.       GO TO 12
  7115. 10    IF (IPR.NE.J) GO TO 11
  7116.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15
  7117.       GO TO 13
  7118. 11    IF (ICON1(IPR).NE.J) GO TO 15
  7119. 12    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  7120.       IF (XI.LT.0.999999D+0) GO TO 15
  7121.       IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 15
  7122. 13    IND2=0
  7123.       GO TO 16
  7124. 14    IND2=1
  7125.       GO TO 16
  7126. 15    IND2=2
  7127. 16    CONTINUE
  7128.       DO 17 I=1,N
  7129.       IJ=I-J
  7130.       XI=X(I)
  7131.       YI=Y(I)
  7132.       ZI=Z(I)
  7133.       AI=BI(I)
  7134.       CALL EFLD (XI,YI,ZI,AI,IJ)
  7135.       CABI=CAB(I)
  7136.       SABI=SAB(I)
  7137.       SALPI=SALP(I)
  7138.       ETK=EXK*CABI+EYK*SABI+EZK*SALPI
  7139.       ETS=EXS*CABI+EYS*SABI+EZS*SALPI
  7140.       ETC=EXC*CABI+EYC*SABI+EZC*SALPI
  7141. 17    E(I)=E(I)-(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD
  7142.       IF (M.EQ.0) GO TO 19
  7143.       IJ=LD+1
  7144.       I1=N
  7145.       DO 18 I=1,M
  7146.       IJ=IJ-1
  7147.       XI=X(IJ)
  7148.       YI=Y(IJ)
  7149.       ZI=Z(IJ)
  7150.       CALL HSFLD (XI,YI,ZI,0.)
  7151.       I1=I1+1
  7152.       TX=T2X(IJ)
  7153.       TY=T2Y(IJ)
  7154.       TZ=T2Z(IJ)
  7155.       ETK=EXK*TX+EYK*TY+EZK*TZ
  7156.       ETS=EXS*TX+EYS*TY+EZS*TZ
  7157.       ETC=EXC*TX+EYC*TY+EZC*TZ
  7158.       E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ)
  7159.       I1=I1+1
  7160.       TX=T1X(IJ)
  7161.       TY=T1Y(IJ)
  7162.       TZ=T1Z(IJ)
  7163.       ETK=EXK*TX+EYK*TY+EZK*TZ
  7164.       ETS=EXS*TX+EYS*TY+EZS*TZ
  7165.       ETC=EXC*TX+EYC*TY+EZC*TZ
  7166. 18    E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ)
  7167. 19    IF (NLOAD.GT.0.OR.NLODF.GT.0) E(J)=E(J)+ZARRAY(J)*CURD*(AX(JX)+CX(
  7168.      1JX))
  7169. 20    CONTINUE
  7170.       RETURN
  7171.       END
  7172.       SUBROUTINE RDPAT
  7173. C ***
  7174. C     DOUBLE PRECISION 6/4/85
  7175. C
  7176.       INCLUDE 'NEC2DPAR.INC'
  7177.       PARAMETER(NORMAX=4*MAXSEG)
  7178.       IMPLICIT REAL*8(A-H,O-Z)
  7179. C ***
  7180. C     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN
  7181.       REAL*8 IGNTP,IGAX,IGTP,HCIR,HBLK,HPOL,HCLIF,ISENS,COM
  7182. C     INTEGER HPOL,HBLK,HCIR,HCLIF
  7183.       COMPLEX*16 ETH,EPH,ERD,ZRATI,ZRATI2,T1,FRATI
  7184.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  7185.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  7186.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  7187.      &IPSYM
  7188.       COMMON/SAVE/IP(2*MAXSEG),KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,
  7189.      &FMHZ
  7190.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  7191.      1IPERF,T1,T2
  7192.       COMMON /FPAT/ NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,GN
  7193.      1OR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,NRX,NRY
  7194.      2,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
  7195.       COMMON /SCRATM/ GAIN(NORMAX)
  7196. C***
  7197.       COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  7198. C***
  7199.       DIMENSION IGTP(4), IGAX(4), IGNTP(10), HPOL(3)
  7200.       DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/,HBLK,HCIR/1H ,6HCIRCLE/
  7201.       DATA IGTP/6H    - ,6HPOWER ,6H- DIRE,6HCTIVE /
  7202.       DATA IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. /
  7203.       DATA IGNTP/6H MAJOR,6H AXIS ,6H MINOR,6H AXIS ,6H   VER,6HTICAL ,6
  7204.      1H HORIZ,6HONTAL ,6H      ,6HTOTAL /
  7205.       DATA PI,TA,TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/
  7206.       IF (IFAR.LT.2) GO TO 2
  7207.       WRITE(3,35)
  7208.       IF (IFAR.LE.3) GO TO 1
  7209.       WRITE(3,36)  NRADL,SCRWLT,SCRWRT
  7210.       IF (IFAR.EQ.4) GO TO 2
  7211. 1     IF (IFAR.EQ.2.OR.IFAR.EQ.5) HCLIF=HPOL(1)
  7212.       IF (IFAR.EQ.3.OR.IFAR.EQ.6) HCLIF=HCIR
  7213.       CL=CLT/WLAM
  7214.       CH=CHT/WLAM
  7215.       ZRATI2=SQRT(1./DCMPLX(EPSR2,-SIG2*WLAM*59.96))
  7216.       WRITE(3,37)  HCLIF,CLT,CHT,EPSR2,SIG2
  7217. 2     IF (IFAR.NE.1) GO TO 3
  7218.       WRITE(3,41)
  7219.       GO TO 5
  7220. 3     I=2*IPD+1
  7221.       J=I+1
  7222.       ITMP1=2*IAX+1
  7223.       ITMP2=ITMP1+1
  7224.       WRITE(3,38)
  7225.       IF (RFLD.LT.1.D-20) GO TO 4
  7226.       EXRM=1./RFLD
  7227.       EXRA=RFLD/WLAM
  7228.       EXRA=-360.*(EXRA-AINT(EXRA))
  7229.       WRITE(3,39)  RFLD,EXRM,EXRA
  7230. 4     WRITE(3,40)  IGTP(I),IGTP(J),IGAX(ITMP1),IGAX(ITMP2)
  7231. 5     IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 7
  7232.       IF (IXTYP.EQ.4) GO TO 6
  7233.       PRAD=0.
  7234.       GCON=4.*PI/(1.+XPR6*XPR6)
  7235.       GCOP=GCON
  7236.       GO TO 8
  7237. 6     PINR=394.51*XPR6*XPR6*WLAM*WLAM
  7238. 7     GCOP=WLAM*WLAM*2.*PI/(376.73*PINR)
  7239.       PRAD=PINR-PLOSS-PNLR
  7240.       GCON=GCOP
  7241.       IF (IPD.NE.0) GCON=GCON*PINR/PRAD
  7242. 8     I=0
  7243.       GMAX=-1.E10
  7244.       PINT=0.
  7245.       TMP1=DPH*TA
  7246.       TMP2=.5*DTH*TA
  7247.       PHI=PHIS-DPH
  7248.       DO 29 KPH=1,NPH
  7249.       PHI=PHI+DPH
  7250.       PHA=PHI*TA
  7251.       THET=THETS-DTH
  7252.       DO 29 KTH=1,NTH
  7253.       THET=THET+DTH
  7254.       IF (KSYMP.EQ.2.AND.THET.GT.90.01.AND.IFAR.NE.1) GO TO 29
  7255.       THA=THET*TA
  7256.       IF (IFAR.EQ.1) GO TO 9
  7257.       CALL FFLD (THA,PHA,ETH,EPH)
  7258.       GO TO 10
  7259. 9     CALL GFLD (RFLD/WLAM,PHA,THET/WLAM,ETH,EPH,ERD,ZRATI,KSYMP)
  7260.       ERDM=ABS(ERD)
  7261.       ERDA=CANG(ERD)
  7262. 10    ETHM2=DREAL(ETH*DCONJG(ETH))
  7263.       ETHM=SQRT(ETHM2)
  7264.       ETHA=CANG(ETH)
  7265.       EPHM2=DREAL(EPH*DCONJG(EPH))
  7266.       EPHM=SQRT(EPHM2)
  7267.       EPHA=CANG(EPH)
  7268.       IF (IFAR.EQ.1) GO TO 28
  7269. C     ELLIPTICAL POLARIZATION CALC.
  7270.       IF (ETHM2.GT.1.D-20.OR.EPHM2.GT.1.D-20) GO TO 11
  7271.       TILTA=0.
  7272.       EMAJR2=0.
  7273.       EMINR2=0.
  7274.       AXRAT=0.
  7275.       ISENS=HBLK
  7276.       GO TO 16
  7277. 11    DFAZ=EPHA-ETHA
  7278.       IF (EPHA.LT.0.) GO TO 12
  7279.       DFAZ2=DFAZ-360.
  7280.       GO TO 13
  7281. 12    DFAZ2=DFAZ+360.
  7282. 13    IF (ABS(DFAZ).GT.ABS(DFAZ2)) DFAZ=DFAZ2
  7283.       CDFAZ=COS(DFAZ*TA)
  7284.       TSTOR1=ETHM2-EPHM2
  7285.       TSTOR2=2.*EPHM*ETHM*CDFAZ
  7286.       TILTA=.5*ATGN2(TSTOR2,TSTOR1)
  7287.       STILTA=SIN(TILTA)
  7288.       TSTOR1=TSTOR1*STILTA*STILTA
  7289.       TSTOR2=TSTOR2*STILTA*COS(TILTA)
  7290.       EMAJR2=-TSTOR1+TSTOR2+ETHM2
  7291.       EMINR2=TSTOR1-TSTOR2+EPHM2
  7292.       IF (EMINR2.LT.0.) EMINR2=0.
  7293.       AXRAT=SQRT(EMINR2/EMAJR2)
  7294.       TILTA=TILTA*TD
  7295.       IF (AXRAT.GT.1.D-5) GO TO 14
  7296.       ISENS=HPOL(1)
  7297.       GO TO 16
  7298. 14    IF (DFAZ.GT.0.) GO TO 15
  7299.       ISENS=HPOL(2)
  7300.       GO TO 16
  7301. 15    ISENS=HPOL(3)
  7302. 16    GNMJ=DB10(GCON*EMAJR2)
  7303.       GNMN=DB10(GCON*EMINR2)
  7304.       GNV=DB10(GCON*ETHM2)
  7305.       GNH=DB10(GCON*EPHM2)
  7306.       GTOT=DB10(GCON*(ETHM2+EPHM2))
  7307.       IF (INOR.LT.1) GO TO 23
  7308.       I=I+1
  7309.       IF (I.GT.NORMAX) GO TO 23
  7310.       GO TO (17,18,19,20,21), INOR
  7311. 17    TSTOR1=GNMJ
  7312.       GO TO 22
  7313. 18    TSTOR1=GNMN
  7314.       GO TO 22
  7315. 19    TSTOR1=GNV
  7316.       GO TO 22
  7317. 20    TSTOR1=GNH
  7318.       GO TO 22
  7319. 21    TSTOR1=GTOT
  7320. 22    GAIN(I)=TSTOR1
  7321.       IF (TSTOR1.GT.GMAX) GMAX=TSTOR1
  7322. 23    IF (IAVP.EQ.0) GO TO 24
  7323.       TSTOR1=GCOP*(ETHM2+EPHM2)
  7324.       TMP3=THA-TMP2
  7325.       TMP4=THA+TMP2
  7326.       IF (KTH.EQ.1) TMP3=THA
  7327.       IF (KTH.EQ.NTH) TMP4=THA
  7328.       DA=ABS(TMP1*(COS(TMP3)-COS(TMP4)))
  7329.       IF (KPH.EQ.1.OR.KPH.EQ.NPH) DA=.5*DA
  7330.       PINT=PINT+TSTOR1*DA
  7331.       IF (IAVP.EQ.2) GO TO 29
  7332. 24    IF (IAX.EQ.1) GO TO 25
  7333.       TMP5=GNMJ
  7334.       TMP6=GNMN
  7335.       GO TO 26
  7336. 25    TMP5=GNV
  7337.       TMP6=GNH
  7338. 26    ETHM=ETHM*WLAM
  7339.       EPHM=EPHM*WLAM
  7340.       IF (RFLD.LT.1.D-20) GO TO 27
  7341.       ETHM=ETHM*EXRM
  7342.       ETHA=ETHA+EXRA
  7343.       EPHM=EPHM*EXRM
  7344.       EPHA=EPHA+EXRA
  7345. 27    WRITE(3,42)  THET,PHI,TMP5,TMP6,GTOT,AXRAT,TILTA,ISENS,ETHM,ETHA
  7346.      1,EPHM,EPHA
  7347. C      GO TO 29
  7348. C***
  7349. C28    WRITE(3,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
  7350.       IF(IPLP1 .NE. 3) GO TO 299
  7351.       IF(IPLP3 .EQ. 0) GO TO 290
  7352.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 1)
  7353.      1WRITE(8,*) THET,ETHM,ETHA
  7354.       IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 2)
  7355.      1WRITE(8,*) THET,EPHM,EPHA
  7356.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 1)
  7357.      1WRITE(8,*) PHI,ETHM,ETHA
  7358.       IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 2)
  7359.      1WRITE(8,*) PHI,EPHM,EPHA
  7360.       IF(IPLP4 .EQ. 0) GO TO 299
  7361. 290   IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 1)
  7362.      1WRITE(8,*) THET,TMP5
  7363.       IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 2)
  7364.      1WRITE(8,*) THET,TMP6
  7365.       IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 3)
  7366.      1WRITE(8,*) THET,GTOT
  7367.       IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 4)
  7368.      1WRITE(8,*) THET,TMP5,TMP6,GTOT
  7369.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 1)
  7370.      1WRITE(8,*) PHI,TMP5
  7371.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 2)
  7372.      1WRITE(8,*) PHI,TMP6
  7373.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 3)
  7374.      1WRITE(8,*) PHI,GTOT
  7375.       IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 4)
  7376.      1WRITE(8,*) PHI,TMP5,TMP6,GTOT
  7377.       GO TO 299
  7378. 28    WRITE(3,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
  7379. 299   CONTINUE
  7380. C***
  7381. 29    CONTINUE
  7382.       IF (IAVP.EQ.0) GO TO 30
  7383.       TMP3=THETS*TA
  7384.       TMP4=TMP3+DTH*TA*DFLOAT(NTH-1)
  7385.       TMP3=ABS(DPH*TA*DFLOAT(NPH-1)*(COS(TMP3)-COS(TMP4)))
  7386.       PINT=PINT/TMP3
  7387.       TMP3=TMP3/PI
  7388.       WRITE(3,44)  PINT,TMP3
  7389. 30    IF (INOR.EQ.0) GO TO 34
  7390.       IF (ABS(GNOR).GT.1.D-20) GMAX=GNOR
  7391.       ITMP1=(INOR-1)*2+1
  7392.       ITMP2=ITMP1+1
  7393.       WRITE(3,45)  IGNTP(ITMP1),IGNTP(ITMP2),GMAX
  7394.       ITMP2=NPH*NTH
  7395.       IF (ITMP2.GT.NORMAX) ITMP2=NORMAX
  7396.       ITMP1=(ITMP2+2)/3
  7397.       ITMP2=ITMP1*3-ITMP2
  7398.       ITMP3=ITMP1
  7399.       ITMP4=2*ITMP1
  7400.       IF (ITMP2.EQ.2) ITMP4=ITMP4-1
  7401.       DO 31 I=1,ITMP1
  7402.       ITMP3=ITMP3+1
  7403.       ITMP4=ITMP4+1
  7404.       J=(I-1)/NTH
  7405.       TMP1=THETS+DFLOAT(I-J*NTH-1)*DTH
  7406.       TMP2=PHIS+DFLOAT(J)*DPH
  7407.       J=(ITMP3-1)/NTH
  7408.       TMP3=THETS+DFLOAT(ITMP3-J*NTH-1)*DTH
  7409.       TMP4=PHIS+DFLOAT(J)*DPH
  7410.       J=(ITMP4-1)/NTH
  7411.       TMP5=THETS+DFLOAT(ITMP4-J*NTH-1)*DTH
  7412.       TMP6=PHIS+DFLOAT(J)*DPH
  7413.       TSTOR1=GAIN(I)-GMAX
  7414.       IF (I.EQ.ITMP1.AND.ITMP2.NE.0) GO TO 32
  7415.       TSTOR2=GAIN(ITMP3)-GMAX
  7416.       PINT=GAIN(ITMP4)-GMAX
  7417. 31    WRITE(3,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2,TMP5,TMP6,PINT
  7418.       GO TO 34
  7419. 32    IF (ITMP2.EQ.2) GO TO 33
  7420.       TSTOR2=GAIN(ITMP3)-GMAX
  7421.       WRITE(3,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2
  7422.       GO TO 34
  7423. 33    WRITE(3,46)  TMP1,TMP2,TSTOR1
  7424. 34    RETURN
  7425. C
  7426. 35    FORMAT (///,31X,39H- - - FAR FIELD GROUND PARAMETERS - - -,//)
  7427. 36    FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,I5,6H WIRES,/,40X,1
  7428.      12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3,
  7429.      27H METERS)
  7430. 37    FORMAT (40X,A6,6H CLIFF,/,40X,14HEDGE DISTANCE=,F9.2,7H METERS,/,4
  7431.      10X,7HHEIGHT=,F8.2,7H METERS,/,40X,15HSECOND MEDIUM -,/,40X,27HRELA
  7432.      2TIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIVITY=,1P,E10.3,
  7433.      35H MHOS)
  7434. 38    FORMAT (///,48X,30H- - - RADIATION PATTERNS - - -)
  7435. 39    FORMAT (54X,6HRANGE=,1P,E13.6,7H METERS,/,54X,12HEXP(-JKR)/R=,
  7436.      1E12.5,9H AT PHASE,0P,F7.2,8H DEGREES,/)
  7437. 40    FORMAT (/,2X,14H- - ANGLES - -,7X,2A6,7HGAINS -,7X,24H- - - POLARI
  7438.      1ZATION - - -,4X,20H- - - E(THETA) - - -,4X,18H- - - E(PHI) - - -,
  7439.      2/,2X,5HTHETA,5X,3HPHI,7X,A6,2X,A6,3X,5HTOTAL,6X,5HAXIAL,5X,4HTILT,
  7440.      33X,5HSENSE,2(5X,9HMAGNITUDE,4X,6HPHASE ),/,2(1X,7HDEGREES,1X),3(
  7441.      46X,2HDB),8X,5HRATIO,5X,4HDEG.,8X,2(6X,7HVOLTS/M,4X,7HDEGREES))
  7442. 41    FORMAT (///,28X,40H - - - RADIATED FIELDS NEAR GROUND - - -,//,8X,
  7443.      120H- - - LOCATION - - -,10X,16H- - E(THETA) - -,8X,14H- - E(PHI) -
  7444.      2 -,8X,17H- - E(RADIAL) - -,/,7X,3HRHO,6X,3HPHI,9X,1HZ,12X,3HMAG,6X
  7445.      3,5HPHASE,9X,3HMAG,6X,5HPHASE,9X,3HMAG,6X,5HPHASE,/,5X,6HMETERS,3X,
  7446.      47HDEGREES,4X,6HMETERS,8X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7H
  7447.      5DEGREES,6X,7HVOLTS/M,3X,7HDEGREES,/)
  7448. 42    FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2))
  7449. 43    FORMAT (3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2))
  7450. 44    FORMAT (//,3X,19HAVERAGE POWER GAIN=,1P,E12.5,7X, 31HSOLID ANGLE U
  7451.      1SED IN AVERAGING=(,0P,F7.4,16H)*PI STERADIANS.,//)
  7452. 45    FORMAT (//,37X,31H- - - - NORMALIZED GAIN - - - -,//,37X,2A6,4HGAI
  7453.      1N,/,38X,22HNORMALIZATION FACTOR =,F9.2,3H DB,//,3(4X,14H- - ANGLES
  7454.      2 - -,6X,4HGAIN,7X),/,3(4X,5HTHETA,5X,3HPHI,8X,2HDB,8X),/,3(3X,7HDE
  7455.      3GREES,2X,7HDEGREES,16X))
  7456. 46    FORMAT (3(1X,2F9.2,1X,F9.2,6X))
  7457.       END
  7458.       SUBROUTINE READGM(INUNIT,CODE,I1,I2,R1,R2,R3,R4,R5,R6,R7)
  7459. C
  7460. C  READGM reads a geometry record and parses it.
  7461. C
  7462. C  *****  Passed variables
  7463. C     CODE        two letter mnemonic code
  7464. C     I1 - I2     integer values from record
  7465. C     R1 - R7     real values from record
  7466. C
  7467.       IMPLICIT REAL*8(A-H,O-Z)
  7468.       CHARACTER*(*) CODE
  7469.       DIMENSION INTVAL(2),REAVAL(7)
  7470. C
  7471. C  Call the routine to read the record and parse it.
  7472. C
  7473.       CALL PARSIT(INUNIT,2,7,CODE,INTVAL,REAVAL,IEOF)
  7474. C
  7475. C  Set the return variables to the buffer array elements.
  7476. C
  7477.       IF(IEOF.LT.0)CODE='GE'
  7478.       I1=INTVAL(1)
  7479.       I2=INTVAL(2)
  7480.       R1=REAVAL(1)
  7481.       R2=REAVAL(2)
  7482.       R3=REAVAL(3)
  7483.       R4=REAVAL(4)
  7484.       R5=REAVAL(5)
  7485.       R6=REAVAL(6)
  7486.       R7=REAVAL(7)
  7487.       RETURN
  7488.       END
  7489.       SUBROUTINE READMN(INUNIT,CODE,I1,I2,I3,I4,F1,F2,F3,F4,F5,F6)
  7490. C
  7491. C  READMN reads a control record and parses it.
  7492. C
  7493.       IMPLICIT REAL*8(A-H,O-Z)
  7494.       CHARACTER*(*) CODE
  7495.       DIMENSION INTVAL(4),REAVAL(6)
  7496. C
  7497. C  Call the routine to read the record and parse it.
  7498. C
  7499.       CALL PARSIT(INUNIT,4,6,CODE,INTVAL,REAVAL,IEOF)
  7500. C
  7501. C  Set the return variables to the buffer array elements.
  7502.       IF(IEOF.LT.0)CODE='EN'
  7503.       I1=INTVAL(1)
  7504.       I2=INTVAL(2)
  7505.       I3=INTVAL(3)
  7506.       I4=INTVAL(4)
  7507.       F1=REAVAL(1)
  7508.       F2=REAVAL(2)
  7509.       F3=REAVAL(3)
  7510.       F4=REAVAL(4)
  7511.       F5=REAVAL(5)
  7512.       F6=REAVAL(6)
  7513.       RETURN
  7514.       END
  7515.       SUBROUTINE PARSIT(INUNIT,MAXINT,MAXREA,CMND,INTFLD,REAFLD,IEOF)
  7516.  
  7517. C  UPDATED:  21 July 87
  7518.  
  7519. C  Called by:   READGM    READMN
  7520.  
  7521. C  PARSIT reads an input record and parses it.
  7522.  
  7523. C  *****  Passed variables
  7524. C     MAXINT     total number of integers in record
  7525. C     MAXREA     total number of real values in record
  7526. C     CMND       two letter mnemonic code
  7527. C     INTFLD     integer values from record
  7528. C     REAFLD     real values from record
  7529.  
  7530. C  *****  Internal Variables
  7531. C     BGNFLD     list of starting indices
  7532. C     BUFFER     text buffer
  7533. C     ENDFLD     list of ending indices
  7534. C     FLDTRM     flag to indicate that pointer is in field position
  7535. C     REC        input line as read
  7536. C     TOTCOL     total number of columns in REC
  7537. C     TOTFLD     number of numeric fields
  7538.       IMPLICIT REAL*8(A-H,O-Z)
  7539.       CHARACTER  CMND*2, BUFFER*20, REC*80
  7540.       INTEGER    INTFLD(MAXINT)
  7541.       INTEGER    BGNFLD(12), ENDFLD(12), TOTCOL, TOTFLD
  7542.       LOGICAL    FLDTRM
  7543.       DIMENSION  REAFLD(MAXREA)
  7544. C
  7545.       READ(INUNIT, 8000, IOSTAT=IEOF) REC
  7546.       CALL UPCASE( REC, REC, TOTCOL )
  7547. C
  7548. C  Store opcode and clear field arrays.
  7549. C
  7550.       CMND= REC(1:2)
  7551.       DO 3000 I=1,MAXINT
  7552.            INTFLD(I)= 0
  7553.  3000 CONTINUE
  7554.       DO 3010 I=1,MAXREA
  7555.            REAFLD(I)= 0.0
  7556.  3010 CONTINUE
  7557.       DO 3020 I=1,12
  7558.            BGNFLD(I)= 0
  7559.            ENDFLD(I)= 0
  7560.  3020 CONTINUE
  7561. C
  7562. C  Find the beginning and ending of each field as well as the total number of
  7563. C  fields.
  7564. C
  7565.       TOTFLD= 0
  7566.       FLDTRM= .FALSE.
  7567.       LAST= MAXREA + MAXINT
  7568.       DO 4000 J=3,TOTCOL
  7569.            K= ICHAR( REC(J:J) )
  7570. C
  7571. C  Check for end of line comment (`!').  This is a new modification to allow
  7572. C  VAX-like comments at the end of data records, i.e.
  7573. C       GW 1 7 0 0 0 0 0 .5 .0001 ! DIPOLE WIRE
  7574. C       GE ! END OF GEOMETRY
  7575. C
  7576.       IF (K .EQ. 33) THEN
  7577.          IF (FLDTRM) ENDFLD(TOTFLD)= J - 1
  7578.          GO TO 5000
  7579. C
  7580. C  Set the ending index when the character is a comma or space and the pointer
  7581. C  is in a field position (FLDTRM = .TRUE.).
  7582. C
  7583.           ELSE IF (K .EQ. 32  .OR.  K .EQ. 44) THEN
  7584.              IF (FLDTRM) THEN
  7585.                 ENDFLD(TOTFLD)= J - 1
  7586.                 FLDTRM= .FALSE.
  7587.              ENDIF
  7588. C
  7589. C  Set the beginning index when the character is not a comma or space and the
  7590. C  pointer is not currently in a field position (FLDTRM = .FALSE).
  7591. C
  7592.           ELSE IF (.NOT. FLDTRM) THEN
  7593.               TOTFLD= TOTFLD + 1
  7594.               FLDTRM= .TRUE.
  7595.               BGNFLD(TOTFLD)= J
  7596.           ENDIF
  7597.  4000   CONTINUE
  7598.         IF (FLDTRM) ENDFLD(TOTFLD)= TOLCOL
  7599.  
  7600. C  Check to see if the total number of value fields is within the precribed
  7601. C  limits.
  7602.  
  7603.  5000   IF (TOTFLD .EQ. 0) THEN
  7604.              RETURN
  7605.         ELSE IF (TOTFLD .GT. LAST) THEN
  7606.              WRITE( 6, 8001 )
  7607.              GOTO 9010
  7608.         ENDIF
  7609.         J= MIN( TOTFLD, MAXINT )
  7610.  
  7611. C  Parse out integer values and store into integer buffer array.
  7612.  
  7613.         DO 5090 I=1,J
  7614.              LENGTH= ENDFLD(I) - BGNFLD(I) + 1
  7615.              BUFFER= REC(BGNFLD(I):ENDFLD(I))
  7616.              IND= INDEX( BUFFER(1:LENGTH), '.' )
  7617.              IF (IND .GT. 0  .AND.  IND .LT. LENGTH) GO TO 9000
  7618.              IF (IND .EQ. LENGTH) LENGTH= LENGTH - 1
  7619.              READ( BUFFER(1:LENGTH), *, ERR=9000 ) INTFLD(I)
  7620.  5090   CONTINUE
  7621.  
  7622. C  Parse out real values and store into real buffer array.
  7623.  
  7624.         IF (TOTFLD .GT. MAXINT) THEN
  7625.              J= MAXINT + 1
  7626.              DO 6000 I=J,TOTFLD
  7627.                   LENGTH= ENDFLD(I) - BGNFLD(I) + 1
  7628.                   BUFFER= REC(BGNFLD(I):ENDFLD(I))
  7629.                   IND= INDEX( BUFFER(1:LENGTH), '.' )
  7630.                   IF (IND .EQ. 0) THEN
  7631.                        INDE= INDEX( BUFFER(1:LENGTH), 'E' )
  7632.                        LENGTH= LENGTH + 1
  7633.                        IF (INDE .EQ. 0) THEN
  7634.                             BUFFER(LENGTH:LENGTH)= '.'
  7635.                        ELSE
  7636.                             BUFFER= BUFFER(1:INDE-1)//'.'//
  7637.      &                               BUFFER(INDE:LENGTH-1)
  7638.                        ENDIF
  7639.                   ENDIF
  7640.                   READ( BUFFER(1:LENGTH), *, ERR=9000 ) REAFLD(I-MAXINT)
  7641.  6000        CONTINUE
  7642.         ENDIF
  7643.         RETURN
  7644.  
  7645. C  Print out text of record line when error occurs.
  7646.  
  7647.  9000   IF (I .LE. MAXINT) THEN
  7648.              WRITE( 6, 8002 ) I
  7649.         ELSE
  7650.              I= I - MAXINT
  7651.              WRITE( 6, 8003 ) I
  7652.         ENDIF
  7653.  9010   WRITE( 6, 8004 ) REC
  7654.         STOP 'CARD ERROR'
  7655. C
  7656. C  Input formats and output messages.
  7657. C
  7658.  8000   FORMAT (A80)
  7659.  8001   FORMAT (//,' ***** CARD ERROR - TOO MANY FIELDS IN RECORD')
  7660.  8002   FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT INTEGER',
  7661.      &          ' POSITION ',I1)
  7662.  8003   FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT REAL',
  7663.      &          ' POSITION ',I1)
  7664.  8004   FORMAT (' ***** TEXT -->  ',A80)
  7665.         END
  7666.         SUBROUTINE UPCASE( INTEXT, OUTTXT, LENGTH )
  7667. C
  7668. C  UPCASE finds the length of INTEXT and converts it to upper case.
  7669. C
  7670.         CHARACTER *(*) INTEXT, OUTTXT
  7671. C
  7672. C
  7673.         LENGTH = LEN( INTEXT )
  7674.         DO 3000 I=1,LENGTH
  7675.              J  = ICHAR( INTEXT(I:I) )
  7676.              IF (J .GE. 96) J = J - 32
  7677.              OUTTXT(I:I) = CHAR( J )
  7678.  3000   CONTINUE
  7679.         RETURN
  7680.         END
  7681.       SUBROUTINE REBLK (B,BX,NB,NBX,N2C)
  7682. C ***
  7683. C     DOUBLE PRECISION 6/4/85
  7684. C
  7685.       IMPLICIT REAL*8(A-H,O-Z)
  7686. C ***
  7687. C     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
  7688. C     TO BLOCKS OF COLUMNS ON TAPE16
  7689.       COMPLEX*16 B,BX
  7690.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  7691.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  7692.       DIMENSION B(NB,1), BX(NBX,1)
  7693.       REWIND 16
  7694.       NIB=0
  7695.       NPB=NPBL
  7696.       DO 3 IB=1,NBBL
  7697.       IF (IB.EQ.NBBL) NPB=NLBL
  7698.       REWIND 14
  7699.       NIX=0
  7700.       NPX=NPBX
  7701.       DO 2 IBX=1,NBBX
  7702.       IF (IBX.EQ.NBBX) NPX=NLBX
  7703.       READ (14) ((BX(I,J),I=1,NPX),J=1,N2C)
  7704.       DO 1 I=1,NPX
  7705.       IX=I+NIX
  7706.       DO 1 J=1,NPB
  7707. 1     B(IX,J)=BX(I,J+NIB)
  7708. 2     NIX=NIX+NPBX
  7709.       WRITE (16) ((B(I,J),I=1,NB),J=1,NPB)
  7710. 3     NIB=NIB+NPBL
  7711.       REWIND 14
  7712.       REWIND 16
  7713.       RETURN
  7714.       END
  7715.       SUBROUTINE REFLC (IX,IY,IZ,ITX,NOP)
  7716. C ***
  7717. C     DOUBLE PRECISION 6/4/85
  7718. C
  7719.       INCLUDE 'NEC2DPAR.INC'
  7720.       IMPLICIT REAL*8(A-H,O-Z)
  7721. C ***
  7722. C
  7723. C     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES
  7724. C     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
  7725. C
  7726.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  7727.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  7728.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  7729.      &IPSYM
  7730.       COMMON /ANGL/ SALP(MAXSEG)
  7731.       DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y
  7732.      12(1), Z2(1)
  7733.       EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
  7734.      12), (T2Z,ITAG), (X2,SI), (Y2,ALP), (Z2,BET)
  7735.       NP=N
  7736.       MP=M
  7737.       IPSYM=0
  7738.       ITI=ITX
  7739.       IF (IX.LT.0) GO TO 19
  7740.       IF (NOP.EQ.0) RETURN
  7741.       IPSYM=1
  7742.       IF (IZ.EQ.0) GO TO 6
  7743. C
  7744. C     REFLECT ALONG Z AXIS
  7745. C
  7746.       IPSYM=2
  7747.       IF (N.LT.N2) GO TO 3
  7748.       DO 2 I=N2,N
  7749.       NX=I+N-N1
  7750.       E1=Z(I)
  7751.       E2=Z2(I)
  7752.       IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 1
  7753.       WRITE(3,24)  I
  7754.       STOP
  7755. 1     X(NX)=X(I)
  7756.       Y(NX)=Y(I)
  7757.       Z(NX)=-E1
  7758.       X2(NX)=X2(I)
  7759.       Y2(NX)=Y2(I)
  7760.       Z2(NX)=-E2
  7761.       ITAGI=ITAG(I)
  7762.       IF (ITAGI.EQ.0) ITAG(NX)=0
  7763.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  7764. 2     BI(NX)=BI(I)
  7765.       N=N*2-N1
  7766.       ITI=ITI*2
  7767. 3     IF (M.LT.M2) GO TO 6
  7768.       NXX=LD+1-M1
  7769.       DO 5 I=M2,M
  7770.       NXX=NXX-1
  7771.       NX=NXX-M+M1
  7772.       IF (ABS(Z(NXX)).GT.1.D-10) GO TO 4
  7773.       WRITE(3,25)  I
  7774.       STOP
  7775. 4     X(NX)=X(NXX)
  7776.       Y(NX)=Y(NXX)
  7777.       Z(NX)=-Z(NXX)
  7778.       T1X(NX)=T1X(NXX)
  7779.       T1Y(NX)=T1Y(NXX)
  7780.       T1Z(NX)=-T1Z(NXX)
  7781.       T2X(NX)=T2X(NXX)
  7782.       T2Y(NX)=T2Y(NXX)
  7783.       T2Z(NX)=-T2Z(NXX)
  7784.       SALP(NX)=-SALP(NXX)
  7785. 5     BI(NX)=BI(NXX)
  7786.       M=M*2-M1
  7787. 6     IF (IY.EQ.0) GO TO 12
  7788. C
  7789. C     REFLECT ALONG Y AXIS
  7790. C
  7791.       IF (N.LT.N2) GO TO 9
  7792.       DO 8 I=N2,N
  7793.       NX=I+N-N1
  7794.       E1=Y(I)
  7795.       E2=Y2(I)
  7796.       IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 7
  7797.       WRITE(3,24)  I
  7798.       STOP
  7799. 7     X(NX)=X(I)
  7800.       Y(NX)=-E1
  7801.       Z(NX)=Z(I)
  7802.       X2(NX)=X2(I)
  7803.       Y2(NX)=-E2
  7804.       Z2(NX)=Z2(I)
  7805.       ITAGI=ITAG(I)
  7806.       IF (ITAGI.EQ.0) ITAG(NX)=0
  7807.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  7808. 8     BI(NX)=BI(I)
  7809.       N=N*2-N1
  7810.       ITI=ITI*2
  7811. 9     IF (M.LT.M2) GO TO 12
  7812.       NXX=LD+1-M1
  7813.       DO 11 I=M2,M
  7814.       NXX=NXX-1
  7815.       NX=NXX-M+M1
  7816.       IF (ABS(Y(NXX)).GT.1.D-10) GO TO 10
  7817.       WRITE(3,25)  I
  7818.       STOP
  7819. 10    X(NX)=X(NXX)
  7820.       Y(NX)=-Y(NXX)
  7821.       Z(NX)=Z(NXX)
  7822.       T1X(NX)=T1X(NXX)
  7823.       T1Y(NX)=-T1Y(NXX)
  7824.       T1Z(NX)=T1Z(NXX)
  7825.       T2X(NX)=T2X(NXX)
  7826.       T2Y(NX)=-T2Y(NXX)
  7827.       T2Z(NX)=T2Z(NXX)
  7828.       SALP(NX)=-SALP(NXX)
  7829. 11    BI(NX)=BI(NXX)
  7830.       M=M*2-M1
  7831. 12    IF (IX.EQ.0) GO TO 18
  7832. C
  7833. C     REFLECT ALONG X AXIS
  7834. C
  7835.       IF (N.LT.N2) GO TO 15
  7836.       DO 14 I=N2,N
  7837.       NX=I+N-N1
  7838.       E1=X(I)
  7839.       E2=X2(I)
  7840.       IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 13
  7841.       WRITE(3,24)  I
  7842.       STOP
  7843. 13    X(NX)=-E1
  7844.       Y(NX)=Y(I)
  7845.       Z(NX)=Z(I)
  7846.       X2(NX)=-E2
  7847.       Y2(NX)=Y2(I)
  7848.       Z2(NX)=Z2(I)
  7849.       ITAGI=ITAG(I)
  7850.       IF (ITAGI.EQ.0) ITAG(NX)=0
  7851.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  7852. 14    BI(NX)=BI(I)
  7853.       N=N*2-N1
  7854. 15    IF (M.LT.M2) GO TO 18
  7855.       NXX=LD+1-M1
  7856.       DO 17 I=M2,M
  7857.       NXX=NXX-1
  7858.       NX=NXX-M+M1
  7859.       IF (ABS(X(NXX)).GT.1.D-10) GO TO 16
  7860.       WRITE(3,25)  I
  7861.       STOP
  7862. 16    X(NX)=-X(NXX)
  7863.       Y(NX)=Y(NXX)
  7864.       Z(NX)=Z(NXX)
  7865.       T1X(NX)=-T1X(NXX)
  7866.       T1Y(NX)=T1Y(NXX)
  7867.       T1Z(NX)=T1Z(NXX)
  7868.       T2X(NX)=-T2X(NXX)
  7869.       T2Y(NX)=T2Y(NXX)
  7870.       T2Z(NX)=T2Z(NXX)
  7871.       SALP(NX)=-SALP(NXX)
  7872. 17    BI(NX)=BI(NXX)
  7873.       M=M*2-M1
  7874. 18    RETURN
  7875. C
  7876. C     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE
  7877. C
  7878. 19    FNOP=NOP
  7879.       IPSYM=-1
  7880.       SAM=6.283185308D+0/FNOP
  7881.       CS=COS(SAM)
  7882.       SS=SIN(SAM)
  7883.       IF (N.LT.N2) GO TO 21
  7884.       N=N1+(N-N1)*NOP
  7885.       NX=NP+1
  7886.       DO 20 I=NX,N
  7887.       K=I-NP+N1
  7888.       XK=X(K)
  7889.       YK=Y(K)
  7890.       X(I)=XK*CS-YK*SS
  7891.       Y(I)=XK*SS+YK*CS
  7892.       Z(I)=Z(K)
  7893.       XK=X2(K)
  7894.       YK=Y2(K)
  7895.       X2(I)=XK*CS-YK*SS
  7896.       Y2(I)=XK*SS+YK*CS
  7897.       Z2(I)=Z2(K)
  7898.       ITAGI=ITAG(K)
  7899.       IF (ITAGI.EQ.0) ITAG(I)=0
  7900.       IF (ITAGI.NE.0) ITAG(I)=ITAGI+ITI
  7901. 20    BI(I)=BI(K)
  7902. 21    IF (M.LT.M2) GO TO 23
  7903.       M=M1+(M-M1)*NOP
  7904.       NX=MP+1
  7905.       K=LD+1-M1
  7906.       DO 22 I=NX,M
  7907.       K=K-1
  7908.       J=K-MP+M1
  7909.       XK=X(K)
  7910.       YK=Y(K)
  7911.       X(J)=XK*CS-YK*SS
  7912.       Y(J)=XK*SS+YK*CS
  7913.       Z(J)=Z(K)
  7914.       XK=T1X(K)
  7915.       YK=T1Y(K)
  7916.       T1X(J)=XK*CS-YK*SS
  7917.       T1Y(J)=XK*SS+YK*CS
  7918.       T1Z(J)=T1Z(K)
  7919.       XK=T2X(K)
  7920.       YK=T2Y(K)
  7921.       T2X(J)=XK*CS-YK*SS
  7922.       T2Y(J)=XK*SS+YK*CS
  7923.       T2Z(J)=T2Z(K)
  7924.       SALP(J)=SALP(K)
  7925. 22    BI(J)=BI(K)
  7926. 23    RETURN
  7927. C
  7928. 24    FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S
  7929.      1YMMETRY)
  7930. 25    FORMAT (27H GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM
  7931.      1METRY)
  7932.       END
  7933.       SUBROUTINE ROM2 (A,B,SUM,DMIN)
  7934. C ***
  7935. C     DOUBLE PRECISION 6/4/85
  7936. C
  7937.       IMPLICIT REAL*8(A-H,O-Z)
  7938. C ***
  7939. C
  7940. C     FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE
  7941. C     SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND.  THE METHOD OF
  7942. C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED.  THERE ARE 9
  7943. C     FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT,
  7944. C     SINE, AND COSINE CURRENT DISTRIBUTIONS.
  7945. C
  7946.       COMPLEX*16 SUM,G1,G2,G3,G4,G5,T00,T01,T10,T02,T11,T20
  7947.       DIMENSION SUM(9), G1(9), G2(9), G3(9), G4(9), G5(9), T01(9), T10(9
  7948.      1), T20(9)
  7949.       DATA NM,NTS,NX,N/65536,4,1,9/,RX/1.D-4/
  7950.       Z=A
  7951.       ZE=B
  7952.       S=B-A
  7953.       IF (S.GE.0.) GO TO 1
  7954.       WRITE(3,18)
  7955.       STOP
  7956. 1     EP=S/(1.E4*NM)
  7957.       ZEND=ZE-EP
  7958.       DO 2 I=1,N
  7959. 2     SUM(I)=(0.,0.)
  7960.       NS=NX
  7961.       NT=0
  7962.       CALL SFLDS (Z,G1)
  7963. 3     DZ=S/NS
  7964.       IF (Z+DZ.LE.ZE) GO TO 4
  7965.       DZ=ZE-Z
  7966.       IF (DZ.LE.EP) GO TO 17
  7967. 4     DZOT=DZ*.5
  7968.       CALL SFLDS (Z+DZOT,G3)
  7969.       CALL SFLDS (Z+DZ,G5)
  7970. 5     TMAG1=0.
  7971.       TMAG2=0.
  7972. C
  7973. C     EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE.
  7974. C
  7975.       DO 6 I=1,N
  7976.       T00=(G1(I)+G5(I))*DZOT
  7977.       T01(I)=(T00+DZ*G3(I))*.5
  7978.       T10(I)=(4.*T01(I)-T00)/3.
  7979.       IF (I.GT.3) GO TO 6
  7980.       TR=DREAL(T01(I))
  7981.       TI=DIMAG(T01(I))
  7982.       TMAG1=TMAG1+TR*TR+TI*TI
  7983.       TR=DREAL(T10(I))
  7984.       TI=DIMAG(T10(I))
  7985.       TMAG2=TMAG2+TR*TR+TI*TI
  7986. 6     CONTINUE
  7987.       TMAG1=SQRT(TMAG1)
  7988.       TMAG2=SQRT(TMAG2)
  7989.       CALL TEST(TMAG1,TMAG2,TR,0.,0.,TI,DMIN)
  7990.       IF(TR.GT.RX)GO TO 8
  7991.       DO 7 I=1,N
  7992. 7     SUM(I)=SUM(I)+T10(I)
  7993.       NT=NT+2
  7994.       GO TO 12
  7995. 8     CALL SFLDS (Z+DZ*.25,G2)
  7996.       CALL SFLDS (Z+DZ*.75,G4)
  7997.       TMAG1=0.
  7998.       TMAG2=0.
  7999. C
  8000. C     EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE.
  8001. C
  8002.       DO 9 I=1,N
  8003.       T02=(T01(I)+DZOT*(G2(I)+G4(I)))*.5
  8004.       T11=(4.*T02-T01(I))/3.
  8005.       T20(I)=(16.*T11-T10(I))/15.
  8006.       IF (I.GT.3) GO TO 9
  8007.       TR=DREAL(T11)
  8008.       TI=DIMAG(T11)
  8009.       TMAG1=TMAG1+TR*TR+TI*TI
  8010.       TR=DREAL(T20(I))
  8011.       TI=DIMAG(T20(I))
  8012.       TMAG2=TMAG2+TR*TR+TI*TI
  8013. 9     CONTINUE
  8014.       TMAG1=SQRT(TMAG1)
  8015.       TMAG2=SQRT(TMAG2)
  8016.       CALL TEST(TMAG1,TMAG2,TR,0.,0.,TI,DMIN)
  8017.       IF(TR.GT.RX)GO TO 14
  8018. 10    DO 11 I=1,N
  8019. 11    SUM(I)=SUM(I)+T20(I)
  8020.       NT=NT+1
  8021. 12    Z=Z+DZ
  8022.       IF (Z.GT.ZEND) GO TO 17
  8023.       DO 13 I=1,N
  8024. 13    G1(I)=G5(I)
  8025.       IF (NT.LT.NTS.OR.NS.LE.NX) GO TO 3
  8026.       NS=NS/2
  8027.       NT=1
  8028.       GO TO 3
  8029. 14    NT=0
  8030.       IF (NS.LT.NM) GO TO 15
  8031.       WRITE(3,19)  Z
  8032.       GO TO 10
  8033. 15    NS=NS*2
  8034.       DZ=S/NS
  8035.       DZOT=DZ*.5
  8036.       DO 16 I=1,N
  8037.       G5(I)=G3(I)
  8038. 16    G3(I)=G2(I)
  8039.       GO TO 5
  8040. 17    CONTINUE
  8041.       RETURN
  8042. C
  8043. 18    FORMAT (30H ERROR - B LESS THAN A IN ROM2)
  8044. 19    FORMAT (33H ROM2 -- STEP SIZE LIMITED AT Z =,1P,E12.5)
  8045.       END
  8046.       SUBROUTINE SBF (I,IS,AA,BB,CC)
  8047. C ***
  8048. C     DOUBLE PRECISION 6/4/85
  8049. C
  8050.       INCLUDE 'NEC2DPAR.INC'
  8051.       IMPLICIT REAL*8(A-H,O-Z)
  8052. C ***
  8053. C     COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.
  8054.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  8055.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  8056.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  8057.      &IPSYM
  8058.       DATA PI/3.141592654D+0/,JMAX/30/
  8059.       AA=0.
  8060.       BB=0.
  8061.       CC=0.
  8062.       JUNE=0
  8063.       JSNO=0
  8064.       PP=0.
  8065.       JCOX=ICON1(I)
  8066.       IF (JCOX.GT.10000) JCOX=I
  8067.       JEND=-1
  8068.       IEND=-1
  8069.       SIG=-1.
  8070.       IF (JCOX) 1,11,2
  8071. 1     JCOX=-JCOX
  8072.       GO TO 3
  8073. 2     SIG=-SIG
  8074.       JEND=-JEND
  8075. 3     JSNO=JSNO+1
  8076.       IF (JSNO.GE.JMAX) GO TO 24
  8077.       D=PI*SI(JCOX)
  8078.       SDH=SIN(D)
  8079.       CDH=COS(D)
  8080.       SD=2.*SDH*CDH
  8081.       IF (D.GT.0.015) GO TO 4
  8082.       OMC=4.*D*D
  8083.       OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
  8084.       GO TO 5
  8085. 4     OMC=1.-CDH*CDH+SDH*SDH
  8086. 5     AJ=1./(LOG(1./(PI*BI(JCOX)))-.577215664D+0)
  8087.       PP=PP-OMC/SD*AJ
  8088.       IF (JCOX.NE.IS) GO TO 6
  8089.       AA=AJ/SD*SIG
  8090.       BB=AJ/(2.*CDH)
  8091.       CC=-AJ/(2.*SDH)*SIG
  8092.       JUNE=IEND
  8093. 6     IF (JCOX.EQ.I) GO TO 9
  8094.       IF (JEND.EQ.1) GO TO 7
  8095.       JCOX=ICON1(JCOX)
  8096.       GO TO 8
  8097. 7     JCOX=ICON2(JCOX)
  8098. 8     IF (IABS(JCOX).EQ.I) GO TO 10
  8099.       IF (JCOX) 1,24,2
  8100. 9     IF (JCOX.EQ.IS) BB=-BB
  8101. 10    IF (IEND.EQ.1) GO TO 12
  8102. 11    PM=-PP
  8103.       PP=0.
  8104.       NJUN1=JSNO
  8105.       JCOX=ICON2(I)
  8106.       IF (JCOX.GT.10000) JCOX=I
  8107.       JEND=1
  8108.       IEND=1
  8109.       SIG=-1.
  8110.       IF (JCOX) 1,12,2
  8111. 12    NJUN2=JSNO-NJUN1
  8112.       D=PI*SI(I)
  8113.       SDH=SIN(D)
  8114.       CDH=COS(D)
  8115.       SD=2.*SDH*CDH
  8116.       CD=CDH*CDH-SDH*SDH
  8117.       IF (D.GT.0.015) GO TO 13
  8118.       OMC=4.*D*D
  8119.       OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
  8120.       GO TO 14
  8121. 13    OMC=1.-CD
  8122. 14    AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0)
  8123.       AJ=AP
  8124.       IF (NJUN1.EQ.0) GO TO 19
  8125.       IF (NJUN2.EQ.0) GO TO 21
  8126.       QP=SD*(PM*PP+AJ*AP)+CD*(PM*AP-PP*AJ)
  8127.       QM=(AP*OMC-PP*SD)/QP
  8128.       QP=-(AJ*OMC+PM*SD)/QP
  8129.       IF (JUNE) 15,18,16
  8130. 15    AA=AA*QM
  8131.       BB=BB*QM
  8132.       CC=CC*QM
  8133.       GO TO 17
  8134. 16    AA=-AA*QP
  8135.       BB=BB*QP
  8136.       CC=-CC*QP
  8137. 17    IF (I.NE.IS) RETURN
  8138. 18    AA=AA-1.
  8139.       BB=BB+(AJ*QM+AP*QP)*SDH/SD
  8140.       CC=CC+(AJ*QM-AP*QP)*CDH/SD
  8141.       RETURN
  8142. 19    IF (NJUN2.EQ.0) GO TO 23
  8143.       QP=PI*BI(I)
  8144.       XXI=QP*QP
  8145.       XXI=QP*(1.-.5*XXI)/(1.-XXI)
  8146.       QP=-(OMC+XXI*SD)/(SD*(AP+XXI*PP)+CD*(XXI*AP-PP))
  8147.       IF (JUNE.NE.1) GO TO 20
  8148.       AA=-AA*QP
  8149.       BB=BB*QP
  8150.       CC=-CC*QP
  8151.       IF (I.NE.IS) RETURN
  8152. 20    AA=AA-1.
  8153.       D=CD-XXI*SD
  8154.       BB=BB+(SDH+AP*QP*(CDH-XXI*SDH))/D
  8155.       CC=CC+(CDH+AP*QP*(SDH+XXI*CDH))/D
  8156.       RETURN
  8157. 21    QM=PI*BI(I)
  8158.       XXI=QM*QM
  8159.       XXI=QM*(1.-.5*XXI)/(1.-XXI)
  8160.       QM=(OMC+XXI*SD)/(SD*(AJ-XXI*PM)+CD*(PM+XXI*AJ))
  8161.       IF (JUNE.NE.-1) GO TO 22
  8162.       AA=AA*QM
  8163.       BB=BB*QM
  8164.       CC=CC*QM
  8165.       IF (I.NE.IS) RETURN
  8166. 22    AA=AA-1.
  8167.       D=CD-XXI*SD
  8168.       BB=BB+(AJ*QM*(CDH-XXI*SDH)-SDH)/D
  8169.       CC=CC+(CDH-AJ*QM*(SDH+XXI*CDH))/D
  8170.       RETURN
  8171. 23    AA=-1.
  8172.       QP=PI*BI(I)
  8173.       XXI=QP*QP
  8174.       XXI=QP*(1.-.5*XXI)/(1.-XXI)
  8175.       CC=1./(CDH-XXI*SDH)
  8176.       RETURN
  8177. 24    WRITE(3,25)  I
  8178.       STOP
  8179. C
  8180. 25    FORMAT (43H SBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
  8181.       END
  8182.       SUBROUTINE SECOND (CPUSECS)
  8183. C
  8184. C     Purpose:
  8185. C     SECOND returns cpu time in seconds.  Must be customized!!!
  8186. C
  8187.       REAL*8 CPUSECS
  8188. C     VAX:
  8189.       COMMON /JPI/ LEN,CPUTIME_CODE,CPUTIME_ADR,ZERO
  8190.       INTEGER*2 LEN,CPUTIME_CODE
  8191.       INTEGER*4 CPUTIME_ADR,CPUTIME
  8192.       DATA LEN/4/,CPUTIME_CODE/'0407'X/,ZERO/0/
  8193.       CPUTIME_ADR=%LOC(CPUTIME)
  8194. C      CALL SYS$GETJPI(,,,LEN,,,)
  8195.       CPUSECS=FLOAT(CPUTIME)/100.
  8196. C
  8197. C     MACINTOSH:
  8198. C      CPUSECS= LONG(362)/60.0
  8199.       RETURN
  8200.       END
  8201.       SUBROUTINE SFLDS (T,E)
  8202. C ***
  8203. C     DOUBLE PRECISION 6/4/85
  8204. C
  8205.       IMPLICIT REAL*8(A-H,O-Z)
  8206. C ***
  8207. C
  8208. C     SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON
  8209. C     THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER.
  8210. C
  8211.       COMPLEX*16 E,ERV,EZV,ERH,EZH,EPH,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC
  8212.      1,EYC,EZC,XX1,XX2,U,U2,ZRATI,ZRATI2,FRATI,ER,ET,HRV,HZV,HRH
  8213.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  8214.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  8215.       COMMON /INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
  8216.       COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH
  8217.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  8218.      1IPERF,T1,T2
  8219.       DIMENSION E(9)
  8220.       DATA PI/3.141592654D+0/,TP/6.283185308D+0/,POT/1.570796327D+0/
  8221.       XT=XJ+T*CABJ
  8222.       YT=YJ+T*SABJ
  8223.       ZT=ZJ+T*SALPJ
  8224.       RHX=XO-XT
  8225.       RHY=YO-YT
  8226.       RHS=RHX*RHX+RHY*RHY
  8227.       RHO=SQRT(RHS)
  8228.       IF (RHO.GT.0.) GO TO 1
  8229.       RHX=1.
  8230.       RHY=0.
  8231.       PHX=0.
  8232.       PHY=1.
  8233.       GO TO 2
  8234. 1     RHX=RHX/RHO
  8235.       RHY=RHY/RHO
  8236.       PHX=-RHY
  8237.       PHY=RHX
  8238. 2     CPH=RHX*XSN+RHY*YSN
  8239.       SPH=RHY*XSN-RHX*YSN
  8240.       IF (ABS(CPH).LT.1.D-10) CPH=0.
  8241.       IF (ABS(SPH).LT.1.D-10) SPH=0.
  8242.       ZPH=ZO+ZT
  8243.       ZPHS=ZPH*ZPH
  8244.       R2S=RHS+ZPHS
  8245.       R2=SQRT(R2S)
  8246.       RK=R2*TP
  8247.       XX2=DCMPLX(COS(RK),-SIN(RK))
  8248.       IF (ISNOR.EQ.1) GO TO 3
  8249. C
  8250. C     USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND.  CURRENT IS
  8251. C     LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE,
  8252. C     OR COSINE DISTRIBUTION.
  8253. C
  8254.       ZMH=1.
  8255.       R1=1.
  8256.       XX1=0.
  8257.       CALL GWAVE (ERV,EZV,ERH,EZH,EPH)
  8258.       ET=-(0.,4.77134)*FRATI*XX2/(R2S*R2)
  8259.       ER=2.*ET*DCMPLX(1.D+0,RK)
  8260.       ET=ET*DCMPLX(1.D+0-RK*RK,RK)
  8261.       HRV=(ER+ET)*RHO*ZPH/R2S
  8262.       HZV=(ZPHS*ER-RHS*ET)/R2S
  8263.       HRH=(RHS*ER-ZPHS*ET)/R2S
  8264.       ERV=ERV-HRV
  8265.       EZV=EZV-HZV
  8266.       ERH=ERH+HRH
  8267.       EZH=EZH+HRV
  8268.       EPH=EPH+ET
  8269.       ERV=ERV*SALPJ
  8270.       EZV=EZV*SALPJ
  8271.       ERH=ERH*SN*CPH
  8272.       EZH=EZH*SN*CPH
  8273.       EPH=EPH*SN*SPH
  8274.       ERH=ERV+ERH
  8275.       E(1)=(ERH*RHX+EPH*PHX)*S
  8276.       E(2)=(ERH*RHY+EPH*PHY)*S
  8277.       E(3)=(EZV+EZH)*S
  8278.       E(4)=0.
  8279.       E(5)=0.
  8280.       E(6)=0.
  8281.       SFAC=PI*S
  8282.       SFAC=SIN(SFAC)/SFAC
  8283.       E(7)=E(1)*SFAC
  8284.       E(8)=E(2)*SFAC
  8285.       E(9)=E(3)*SFAC
  8286.       RETURN
  8287. C
  8288. C     INTERPOLATE IN SOMMERFELD FIELD TABLES
  8289. C
  8290. 3     IF (RHO.LT.1.D-12) GO TO 4
  8291.       THET=ATAN(ZPH/RHO)
  8292.       GO TO 5
  8293. 4     THET=POT
  8294. 5     CALL INTRP (R2,THET,ERV,EZV,ERH,EPH)
  8295. C     COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z
  8296. C     COMPONENTS.  MULTIPLY BY EXP(-JKR)/R.
  8297.       XX2=XX2/R2
  8298.       SFAC=SN*CPH
  8299.       ERH=XX2*(SALPJ*ERV+SFAC*ERH)
  8300.       EZH=XX2*(SALPJ*EZV-SFAC*ERV)
  8301.       EPH=SN*SPH*XX2*EPH
  8302. C     X,Y,Z FIELDS FOR CONSTANT CURRENT
  8303.       E(1)=ERH*RHX+EPH*PHX
  8304.       E(2)=ERH*RHY+EPH*PHY
  8305.       E(3)=EZH
  8306.       RK=TP*T
  8307. C     X,Y,Z FIELDS FOR SINE CURRENT
  8308.       SFAC=SIN(RK)
  8309.       E(4)=E(1)*SFAC
  8310.       E(5)=E(2)*SFAC
  8311.       E(6)=E(3)*SFAC
  8312. C     X,Y,Z FIELDS FOR COSINE CURRENT
  8313.       SFAC=COS(RK)
  8314.       E(7)=E(1)*SFAC
  8315.       E(8)=E(2)*SFAC
  8316.       E(9)=E(3)*SFAC
  8317.       RETURN
  8318.       END
  8319.       SUBROUTINE SOLGF (A,B,C,D,XY,IP,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ)
  8320. C ***
  8321. C     DOUBLE PRECISION 6/4/85
  8322. C
  8323.       INCLUDE 'NEC2DPAR.INC'
  8324.       IMPLICIT REAL*8(A-H,O-Z)
  8325. C ***
  8326. C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE
  8327.       COMPLEX*16 A,B,C,D,SUM,XY,Y
  8328.       COMMON /SCRATM/ Y(2*MAXSEG)
  8329.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  8330.      1CON(10),NPCON
  8331.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  8332.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  8333.       DIMENSION A(1), B(N1C,1), C(N1C,1), D(N2CZ,1), IP(1), XY(1)
  8334.       IFL=14
  8335.       IF (ICASX.GT.0) IFL=13
  8336.       IF (N2C.GT.0) GO TO 1
  8337. C     NORMAL SOLUTION.  NOT N.G.F.
  8338.       CALL SOLVES (A,IP,XY,N1C,1,NP,N,MP,M,13,IFL)
  8339.       GO TO 22
  8340. 1     IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5
  8341. C     REORDER EXCITATION ARRAY
  8342.       N2=N1+1
  8343.       JJ=N+1
  8344.       NPM=N+2*M1
  8345.       DO 2 I=N2,NPM
  8346. 2     Y(I)=XY(I)
  8347.       J=N1
  8348.       DO 3 I=JJ,NPM
  8349.       J=J+1
  8350. 3     XY(J)=Y(I)
  8351.       DO 4 I=N2,N
  8352.       J=J+1
  8353. 4     XY(J)=Y(I)
  8354. 5     NEQS=NSCON+2*NPCON
  8355.       IF (NEQS.EQ.0) GO TO 7
  8356.       NEQ=N1C+N2C
  8357.       NEQS=NEQ-NEQS+1
  8358. C     COMPUTE INV(A)E1
  8359.       DO 6 I=NEQS,NEQ
  8360. 6     XY(I)=(0.,0.)
  8361. 7     CALL SOLVES (A,IP,XY,N1C,1,NP,N1,MP,M1,13,IFL)
  8362.       NI=0
  8363.       NPB=NPBL
  8364. C     COMPUTE E2-C(INV(A)E1)
  8365.       DO 10 JJ=1,NBBL
  8366.       IF (JJ.EQ.NBBL) NPB=NLBL
  8367.       IF (ICASX.GT.1) READ (15) ((C(I,J),I=1,N1C),J=1,NPB)
  8368.       II=N1C+NI
  8369.       DO 9 I=1,NPB
  8370.       SUM=(0.,0.)
  8371.       DO 8 J=1,N1C
  8372. 8     SUM=SUM+C(J,I)*XY(J)
  8373.       J=II+I
  8374. 9     XY(J)=XY(J)-SUM
  8375. 10    NI=NI+NPBL
  8376.       REWIND 15
  8377.       JJ=N1C+1
  8378. C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
  8379.       IF (ICASX.GT.1) GO TO 11
  8380.       CALL SOLVE (N2C,D,IP(JJ),XY(JJ),N2C)
  8381.       GO TO 13
  8382. 11    IF (ICASX.EQ.4) GO TO 12
  8383.       NI=N2C*N2C
  8384.       READ (11) (B(J,1),J=1,NI)
  8385.       REWIND 11
  8386.       CALL SOLVE (N2C,B,IP(JJ),XY(JJ),N2C)
  8387.       GO TO 13
  8388. 12    NBLSYS=NBLSYM
  8389.       NPSYS=NPSYM
  8390.       NLSYS=NLSYM
  8391.       ICASS=ICASE
  8392.       NBLSYM=NBBL
  8393.       NPSYM=NPBL
  8394.       NLSYM=NLBL
  8395.       ICASE=3
  8396.       REWIND 11
  8397.       REWIND 16
  8398.       CALL LTSOLV (B,N2C,IP(JJ),XY(JJ),N2C,1,11,16)
  8399.       REWIND 11
  8400.       REWIND 16
  8401.       NBLSYM=NBLSYS
  8402.       NPSYM=NPSYS
  8403.       NLSYM=NLSYS
  8404.       ICASE=ICASS
  8405. 13    NI=0
  8406.       NPB=NPBL
  8407. C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1
  8408.       DO 16 JJ=1,NBBL
  8409.       IF (JJ.EQ.NBBL) NPB=NLBL
  8410.       IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
  8411.       II=N1C+NI
  8412.       DO 15 I=1,N1C
  8413.       SUM=(0.,0.)
  8414.       DO 14 J=1,NPB
  8415.       JP=II+J
  8416. 14    SUM=SUM+B(I,J)*XY(JP)
  8417. 15    XY(I)=XY(I)-SUM
  8418. 16    NI=NI+NPBL
  8419.       REWIND 14
  8420.       IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20
  8421. C     REORDER CURRENT ARRAY
  8422.       DO 17 I=N2,NPM
  8423. 17    Y(I)=XY(I)
  8424.       JJ=N1C+1
  8425.       J=N1
  8426.       DO 18 I=JJ,NPM
  8427.       J=J+1
  8428. 18    XY(J)=Y(I)
  8429.       DO 19 I=N2,N1C
  8430.       J=J+1
  8431. 19    XY(J)=Y(I)
  8432. 20    IF (NSCON.EQ.0) GO TO 22
  8433.       J=NEQS-1
  8434.       DO 21 I=1,NSCON
  8435.       J=J+1
  8436.       JJ=ISCON(I)
  8437. 21    XY(JJ)=XY(J)
  8438. 22    RETURN
  8439.       END
  8440.       SUBROUTINE SOLVE (N,A,IP,B,NDIM)
  8441. C ***
  8442. C     DOUBLE PRECISION 6/4/85
  8443. C
  8444.       INCLUDE 'NEC2DPAR.INC'
  8445.       IMPLICIT REAL*8(A-H,O-Z)
  8446. C ***
  8447. C
  8448. C     SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT
  8449. C     LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH
  8450. C     OF WHICH ARE STORED IN A.  THE RHS VECTOR B IS INPUT AND THE
  8451. C     SOLUTION IS RETURNED THROUGH VECTOR B.    (MATRIX TRANSPOSED.
  8452. C
  8453.       COMPLEX*16 A,B,Y,SUM
  8454.       INTEGER PI
  8455.       COMMON /SCRATM/ Y(2*MAXSEG)
  8456.       DIMENSION A(NDIM,NDIM), IP(NDIM), B(NDIM)
  8457. C
  8458. C     FORWARD SUBSTITUTION
  8459. C
  8460.       DO 3 I=1,N
  8461.       PI=IP(I)
  8462.       Y(I)=B(PI)
  8463.       B(PI)=B(I)
  8464.       IP1=I+1
  8465.       IF (IP1.GT.N) GO TO 2
  8466.       DO 1 J=IP1,N
  8467.       B(J)=B(J)-A(I,J)*Y(I)
  8468. 1     CONTINUE
  8469. 2     CONTINUE
  8470. 3     CONTINUE
  8471. C
  8472. C     BACKWARD SUBSTITUTION
  8473. C
  8474.       DO 6 K=1,N
  8475.       I=N-K+1
  8476.       SUM=(0.,0.)
  8477.       IP1=I+1
  8478.       IF (IP1.GT.N) GO TO 5
  8479.       DO 4 J=IP1,N
  8480.       SUM=SUM+A(J,I)*B(J)
  8481. 4     CONTINUE
  8482. 5     CONTINUE
  8483.       B(I)=(Y(I)-SUM)/A(I,I)
  8484. 6     CONTINUE
  8485.       RETURN
  8486.       END
  8487.       SUBROUTINE SOLVES (A,IP,B,NEQ,NRH,NP,N,MP,M,IFL1,IFL2)
  8488. C ***
  8489. C     DOUBLE PRECISION 6/4/85
  8490. C
  8491.       INCLUDE 'NEC2DPAR.INC'
  8492.       IMPLICIT REAL*8(A-H,O-Z)
  8493. C ***
  8494. C
  8495. C     SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE
  8496. C     TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE
  8497. C     MATRIX EQ.
  8498. C
  8499.       COMPLEX*16 A,B,Y,SUM,SSX
  8500.       COMMON /SMAT/ SSX(16,16)
  8501.       COMMON /SCRATM/ Y(2*MAXSEG)
  8502.       COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
  8503.      1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  8504.       DIMENSION A(1), IP(1), B(NEQ,NRH)
  8505.       NPEQ=NP+2*MP
  8506.       NOP=NEQ/NPEQ
  8507.       FNOP=NOP
  8508.       FNORM=1./FNOP
  8509.       NROW=NEQ
  8510.       IF (ICASE.GT.3) NROW=NPEQ
  8511.       IF (NOP.EQ.1) GO TO 11
  8512.       DO 10 IC=1,NRH
  8513.       IF (N.EQ.0.OR.M.EQ.0) GO TO 6
  8514.       DO 1 I=1,NEQ
  8515. 1     Y(I)=B(I,IC)
  8516.       KK=2*MP
  8517.       IA=NP
  8518.       IB=N
  8519.       J=NP
  8520.       DO 5 K=1,NOP
  8521.       IF (K.EQ.1) GO TO 3
  8522.       DO 2 I=1,NP
  8523.       IA=IA+1
  8524.       J=J+1
  8525. 2     B(J,IC)=Y(IA)
  8526.       IF (K.EQ.NOP) GO TO 5
  8527. 3     DO 4 I=1,KK
  8528.       IB=IB+1
  8529.       J=J+1
  8530. 4     B(J,IC)=Y(IB)
  8531. 5     CONTINUE
  8532. C
  8533. C     TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
  8534. C
  8535. 6     DO 10 I=1,NPEQ
  8536.       DO 7 K=1,NOP
  8537.       IA=I+(K-1)*NPEQ
  8538. 7     Y(K)=B(IA,IC)
  8539.       SUM=Y(1)
  8540.       DO 8 K=2,NOP
  8541. 8     SUM=SUM+Y(K)
  8542.       B(I,IC)=SUM*FNORM
  8543.       DO 10 K=2,NOP
  8544.       IA=I+(K-1)*NPEQ
  8545.       SUM=Y(1)
  8546.       DO 9 J=2,NOP
  8547. 9     SUM=SUM+Y(J)*DCONJG(SSX(K,J))
  8548. 10    B(IA,IC)=SUM*FNORM
  8549. 11    IF (ICASE.LT.3) GO TO 12
  8550.       REWIND IFL1
  8551.       REWIND IFL2
  8552. C
  8553. C     SOLVE EACH MODE EQUATION
  8554. C
  8555. 12    DO 16 KK=1,NOP
  8556.       IA=(KK-1)*NPEQ+1
  8557.       IB=IA
  8558.       IF (ICASE.NE.4) GO TO 13
  8559.       I=NPEQ*NPEQ
  8560.       READ (IFL1) (A(J),J=1,I)
  8561.       IB=1
  8562. 13    IF (ICASE.EQ.3.OR.ICASE.EQ.5) GO TO 15
  8563.       DO 14 IC=1,NRH
  8564. 14    CALL SOLVE (NPEQ,A(IB),IP(IA),B(IA,IC),NROW)
  8565.       GO TO 16
  8566. 15    CALL LTSOLV (A,NPEQ,IP(IA),B(IA,1),NEQ,NRH,IFL1,IFL2)
  8567. 16    CONTINUE
  8568.       IF (NOP.EQ.1) RETURN
  8569. C
  8570. C     INVERSE TRANSFORM THE MODE SOLUTIONS
  8571. C
  8572.       DO 26 IC=1,NRH
  8573.       DO 20 I=1,NPEQ
  8574.       DO 17 K=1,NOP
  8575.       IA=I+(K-1)*NPEQ
  8576. 17    Y(K)=B(IA,IC)
  8577.       SUM=Y(1)
  8578.       DO 18 K=2,NOP
  8579. 18    SUM=SUM+Y(K)
  8580.       B(I,IC)=SUM
  8581.       DO 20 K=2,NOP
  8582.       IA=I+(K-1)*NPEQ
  8583.       SUM=Y(1)
  8584.       DO 19 J=2,NOP
  8585. 19    SUM=SUM+Y(J)*SSX(K,J)
  8586. 20    B(IA,IC)=SUM
  8587.       IF (N.EQ.0.OR.M.EQ.0) GO TO 26
  8588.       DO 21 I=1,NEQ
  8589. 21    Y(I)=B(I,IC)
  8590.       KK=2*MP
  8591.       IA=NP
  8592.       IB=N
  8593.       J=NP
  8594.       DO 25 K=1,NOP
  8595.       IF (K.EQ.1) GO TO 23
  8596.       DO 22 I=1,NP
  8597.       IA=IA+1
  8598.       J=J+1
  8599. 22    B(IA,IC)=Y(J)
  8600.       IF (K.EQ.NOP) GO TO 25
  8601. 23    DO 24 I=1,KK
  8602.       IB=IB+1
  8603.       J=J+1
  8604. 24    B(IB,IC)=Y(J)
  8605. 25    CONTINUE
  8606. 26    CONTINUE
  8607.       RETURN
  8608.       END
  8609.       SUBROUTINE TBF (I,ICAP)
  8610. C ***
  8611. C     DOUBLE PRECISION 6/4/85
  8612. C
  8613.       INCLUDE 'NEC2DPAR.INC'
  8614.       IMPLICIT REAL*8(A-H,O-Z)
  8615. C ***
  8616. C     COMPUTE BASIS FUNCTION I
  8617.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  8618.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  8619.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  8620.      &IPSYM
  8621.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  8622.      1CON(10),NPCON
  8623.       DATA PI/3.141592654D+0/,JMAX/30/
  8624.       JSNO=0
  8625.       PP=0.
  8626.       JCOX=ICON1(I)
  8627.       IF (JCOX.GT.10000) JCOX=I
  8628.       JEND=-1
  8629.       IEND=-1
  8630.       SIG=-1.
  8631.       IF (JCOX) 1,10,2
  8632. 1     JCOX=-JCOX
  8633.       GO TO 3
  8634. 2     SIG=-SIG
  8635.       JEND=-JEND
  8636. 3     JSNO=JSNO+1
  8637.       IF (JSNO.GE.JMAX) GO TO 28
  8638.       JCO(JSNO)=JCOX
  8639.       D=PI*SI(JCOX)
  8640.       SDH=SIN(D)
  8641.       CDH=COS(D)
  8642.       SD=2.*SDH*CDH
  8643.       IF (D.GT.0.015) GO TO 4
  8644.       OMC=4.*D*D
  8645.       OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
  8646.       GO TO 5
  8647. 4     OMC=1.-CDH*CDH+SDH*SDH
  8648. 5     AJ=1./(LOG(1./(PI*BI(JCOX)))-.577215664D+0)
  8649.       PP=PP-OMC/SD*AJ
  8650.       AX(JSNO)=AJ/SD*SIG
  8651.       BX(JSNO)=AJ/(2.*CDH)
  8652.       CX(JSNO)=-AJ/(2.*SDH)*SIG
  8653.       IF (JCOX.EQ.I) GO TO 8
  8654.       IF (JEND.EQ.1) GO TO 6
  8655.       JCOX=ICON1(JCOX)
  8656.       GO TO 7
  8657. 6     JCOX=ICON2(JCOX)
  8658. 7     IF (IABS(JCOX).EQ.I) GO TO 9
  8659.       IF (JCOX) 1,28,2
  8660. 8     BX(JSNO)=-BX(JSNO)
  8661. 9     IF (IEND.EQ.1) GO TO 11
  8662. 10    PM=-PP
  8663.       PP=0.
  8664.       NJUN1=JSNO
  8665.       JCOX=ICON2(I)
  8666.       IF (JCOX.GT.10000) JCOX=I
  8667.       JEND=1
  8668.       IEND=1
  8669.       SIG=-1.
  8670.       IF (JCOX) 1,11,2
  8671. 11    NJUN2=JSNO-NJUN1
  8672.       JSNOP=JSNO+1
  8673.       JCO(JSNOP)=I
  8674.       D=PI*SI(I)
  8675.       SDH=SIN(D)
  8676.       CDH=COS(D)
  8677.       SD=2.*SDH*CDH
  8678.       CD=CDH*CDH-SDH*SDH
  8679.       IF (D.GT.0.015) GO TO 12
  8680.       OMC=4.*D*D
  8681.       OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
  8682.       GO TO 13
  8683. 12    OMC=1.-CD
  8684. 13    AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0)
  8685.       AJ=AP
  8686.       IF (NJUN1.EQ.0) GO TO 16
  8687.       IF (NJUN2.EQ.0) GO TO 20
  8688.       QP=SD*(PM*PP+AJ*AP)+CD*(PM*AP-PP*AJ)
  8689.       QM=(AP*OMC-PP*SD)/QP
  8690.       QP=-(AJ*OMC+PM*SD)/QP
  8691.       BX(JSNOP)=(AJ*QM+AP*QP)*SDH/SD
  8692.       CX(JSNOP)=(AJ*QM-AP*QP)*CDH/SD
  8693.       DO 14 IEND=1,NJUN1
  8694.       AX(IEND)=AX(IEND)*QM
  8695.       BX(IEND)=BX(IEND)*QM
  8696. 14    CX(IEND)=CX(IEND)*QM
  8697.       JEND=NJUN1+1
  8698.       DO 15 IEND=JEND,JSNO
  8699.       AX(IEND)=-AX(IEND)*QP
  8700.       BX(IEND)=BX(IEND)*QP
  8701. 15    CX(IEND)=-CX(IEND)*QP
  8702.       GO TO 27
  8703. 16    IF (NJUN2.EQ.0) GO TO 24
  8704.       IF (ICAP.NE.0) GO TO 17
  8705.       XXI=0.
  8706.       GO TO 18
  8707. 17    QP=PI*BI(I)
  8708.       XXI=QP*QP
  8709.       XXI=QP*(1.-.5*XXI)/(1.-XXI)
  8710. 18    QP=-(OMC+XXI*SD)/(SD*(AP+XXI*PP)+CD*(XXI*AP-PP))
  8711.       D=CD-XXI*SD
  8712.       BX(JSNOP)=(SDH+AP*QP*(CDH-XXI*SDH))/D
  8713.       CX(JSNOP)=(CDH+AP*QP*(SDH+XXI*CDH))/D
  8714.       DO 19 IEND=1,NJUN2
  8715.       AX(IEND)=-AX(IEND)*QP
  8716.       BX(IEND)=BX(IEND)*QP
  8717. 19    CX(IEND)=-CX(IEND)*QP
  8718.       GO TO 27
  8719. 20    IF (ICAP.NE.0) GO TO 21
  8720.       XXI=0.
  8721.       GO TO 22
  8722. 21    QM=PI*BI(I)
  8723.       XXI=QM*QM
  8724.       XXI=QM*(1.-.5*XXI)/(1.-XXI)
  8725. 22    QM=(OMC+XXI*SD)/(SD*(AJ-XXI*PM)+CD*(PM+XXI*AJ))
  8726.       D=CD-XXI*SD
  8727.       BX(JSNOP)=(AJ*QM*(CDH-XXI*SDH)-SDH)/D
  8728.       CX(JSNOP)=(CDH-AJ*QM*(SDH+XXI*CDH))/D
  8729.       DO 23 IEND=1,NJUN1
  8730.       AX(IEND)=AX(IEND)*QM
  8731.       BX(IEND)=BX(IEND)*QM
  8732. 23    CX(IEND)=CX(IEND)*QM
  8733.       GO TO 27
  8734. 24    BX(JSNOP)=0.
  8735.       IF (ICAP.NE.0) GO TO 25
  8736.       XXI=0.
  8737.       GO TO 26
  8738. 25    QP=PI*BI(I)
  8739.       XXI=QP*QP
  8740.       XXI=QP*(1.-.5*XXI)/(1.-XXI)
  8741. 26    CX(JSNOP)=1./(CDH-XXI*SDH)
  8742. 27    JSNO=JSNOP
  8743.       AX(JSNO)=-1.
  8744.       RETURN
  8745. 28    WRITE(3,29)  I
  8746.       STOP
  8747. C
  8748. 29    FORMAT (43H TBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
  8749.       END
  8750.       SUBROUTINE TEST (F1R,F2R,TR,F1I,F2I,TI,DMIN)
  8751. C ***
  8752. C     DOUBLE PRECISION 6/4/85
  8753. C
  8754.       IMPLICIT REAL*8(A-H,O-Z)
  8755. C ***
  8756. C
  8757. C     TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION
  8758. C
  8759.       DEN=ABS(F2R)
  8760.       TR=ABS(F2I)
  8761.       IF (DEN.LT.TR) DEN=TR
  8762.       IF (DEN.LT.DMIN) DEN=DMIN
  8763.       IF (DEN.LT.1.D-37) GO TO 1
  8764.       TR=ABS((F1R-F2R)/DEN)
  8765.       TI=ABS((F1I-F2I)/DEN)
  8766.       RETURN
  8767. 1     TR=0.
  8768.       TI=0.
  8769.       RETURN
  8770.       END
  8771.       SUBROUTINE TRIO (J)
  8772. C ***
  8773. C     DOUBLE PRECISION 6/4/85
  8774. C
  8775.       INCLUDE 'NEC2DPAR.INC'
  8776.       IMPLICIT REAL*8(A-H,O-Z)
  8777. C ***
  8778. C     COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J
  8779.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  8780.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  8781.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  8782.      &IPSYM
  8783.       COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
  8784.      1CON(10),NPCON
  8785.       DATA JMAX/30/
  8786.       JSNO=0
  8787.       JCOX=ICON1(J)
  8788.       IF (JCOX.GT.10000) GO TO 7
  8789.       JEND=-1
  8790.       IEND=-1
  8791.       IF (JCOX) 1,7,2
  8792. 1     JCOX=-JCOX
  8793.       GO TO 3
  8794. 2     JEND=-JEND
  8795. 3     IF (JCOX.EQ.J) GO TO 6
  8796.       JSNO=JSNO+1
  8797.       IF (JSNO.GE.JMAX) GO TO 9
  8798.       CALL SBF (JCOX,J,AX(JSNO),BX(JSNO),CX(JSNO))
  8799.       JCO(JSNO)=JCOX
  8800.       IF (JEND.EQ.1) GO TO 4
  8801.       JCOX=ICON1(JCOX)
  8802.       GO TO 5
  8803. 4     JCOX=ICON2(JCOX)
  8804. 5     IF (JCOX) 1,9,2
  8805. 6     IF (IEND.EQ.1) GO TO 8
  8806. 7     JCOX=ICON2(J)
  8807.       IF (JCOX.GT.10000) GO TO 8
  8808.       JEND=1
  8809.       IEND=1
  8810.       IF (JCOX) 1,8,2
  8811. 8     JSNO=JSNO+1
  8812.       CALL SBF (J,J,AX(JSNO),BX(JSNO),CX(JSNO))
  8813.       JCO(JSNO)=J
  8814.       RETURN
  8815. 9     WRITE(3,10)  J
  8816.       STOP
  8817. C
  8818. 10    FORMAT (44H TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT,I5)
  8819.       END
  8820.       SUBROUTINE UNERE (XOB,YOB,ZOB)
  8821. C ***
  8822. C     DOUBLE PRECISION 6/4/85
  8823. C
  8824.       IMPLICIT REAL*8(A-H,O-Z)
  8825. C ***
  8826. C     CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
  8827. C     DIRECTIONS ON A PATCH
  8828.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1
  8829.      1,ER,Q1,Q2,RRV,RRH,EDP,FRATI
  8830.       COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,EZ
  8831.      1S,EXC,EYC,EZC,RKH,IEXK,IND1,INDD1,IND2,INDD2,IPGND
  8832.       COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
  8833.      1IPERF,T1,T2
  8834. C     EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
  8835. C    1J,IND1), (T2ZJ,IND2)
  8836.       DATA TPI,CONST/6.283185308D+0,4.771341188D+0/
  8837. C     CONST=ETA/(8.*PI**2)
  8838.       ZR=ZJ
  8839.       T1ZR=T1ZJ
  8840.       T2ZR=T2ZJ
  8841.       IF (IPGND.NE.2) GO TO 1
  8842.       ZR=-ZR
  8843.       T1ZR=-T1ZR
  8844.       T2ZR=-T2ZR
  8845. 1     RX=XOB-XJ
  8846.       RY=YOB-YJ
  8847.       RZ=ZOB-ZR
  8848.       R2=RX*RX+RY*RY+RZ*RZ
  8849.       IF (R2.GT.1.D-20) GO TO 2
  8850.       EXK=(0.,0.)
  8851.       EYK=(0.,0.)
  8852.       EZK=(0.,0.)
  8853.       EXS=(0.,0.)
  8854.       EYS=(0.,0.)
  8855.       EZS=(0.,0.)
  8856.       RETURN
  8857. 2     R=SQRT(R2)
  8858.       TT1=-TPI*R
  8859.       TT2=TT1*TT1
  8860.       RT=R2*R
  8861.       ER=DCMPLX(SIN(TT1),-COS(TT1))*(CONST*S)
  8862.       Q1=DCMPLX(TT2-1.,TT1)*ER/RT
  8863.       Q2=DCMPLX(3.-TT2,-3.*TT1)*ER/(RT*R2)
  8864.       ER=Q2*(T1XJ*RX+T1YJ*RY+T1ZR*RZ)
  8865.       EXK=Q1*T1XJ+ER*RX
  8866.       EYK=Q1*T1YJ+ER*RY
  8867.       EZK=Q1*T1ZR+ER*RZ
  8868.       ER=Q2*(T2XJ*RX+T2YJ*RY+T2ZR*RZ)
  8869.       EXS=Q1*T2XJ+ER*RX
  8870.       EYS=Q1*T2YJ+ER*RY
  8871.       EZS=Q1*T2ZR+ER*RZ
  8872.       IF (IPGND.EQ.1) GO TO 6
  8873.       IF (IPERF.NE.1) GO TO 3
  8874.       EXK=-EXK
  8875.       EYK=-EYK
  8876.       EZK=-EZK
  8877.       EXS=-EXS
  8878.       EYS=-EYS
  8879.       EZS=-EZS
  8880.       GO TO 6
  8881. 3     XYMAG=SQRT(RX*RX+RY*RY)
  8882.       IF (XYMAG.GT.1.D-6) GO TO 4
  8883.       PX=0.
  8884.       PY=0.
  8885.       CTH=1.
  8886.       RRV=(1.,0.)
  8887.       GO TO 5
  8888. 4     PX=-RY/XYMAG
  8889.       PY=RX/XYMAG
  8890.       CTH=RZ/SQRT(XYMAG*XYMAG+RZ*RZ)
  8891.       RRV=SQRT(1.-ZRATI*ZRATI*(1.-CTH*CTH))
  8892. 5     RRH=ZRATI*CTH
  8893.       RRH=(RRH-RRV)/(RRH+RRV)
  8894.       RRV=ZRATI*RRV
  8895.       RRV=-(CTH-RRV)/(CTH+RRV)
  8896.       EDP=(EXK*PX+EYK*PY)*(RRH-RRV)
  8897.       EXK=EXK*RRV+EDP*PX
  8898.       EYK=EYK*RRV+EDP*PY
  8899.       EZK=EZK*RRV
  8900.       EDP=(EXS*PX+EYS*PY)*(RRH-RRV)
  8901.       EXS=EXS*RRV+EDP*PX
  8902.       EYS=EYS*RRV+EDP*PY
  8903.       EZS=EZS*RRV
  8904. 6     RETURN
  8905.       END
  8906.       SUBROUTINE WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,RDEL,RRAD,NS,ITG)
  8907. C ***
  8908. C     DOUBLE PRECISION 6/4/85
  8909. C
  8910.       INCLUDE 'NEC2DPAR.INC'
  8911.       IMPLICIT REAL*8(A-H,O-Z)
  8912. C ***
  8913. C
  8914. C     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT
  8915. C     WIRE OF NS SEGMENTS.
  8916. C
  8917.       COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(MAXSEG),Y(MAXSEG),
  8918.      &Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),ALP(MAXSEG),BET(MAXSEG),
  8919.      &ICON1(2*MAXSEG),ICON2(2*MAXSEG),ITAG(2*MAXSEG),ICONX(MAXSEG),WLAM,
  8920.      &IPSYM
  8921.       DIMENSION X2(1), Y2(1), Z2(1)
  8922.       EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1))
  8923.       IST=N+1
  8924.       N=N+NS
  8925.       NP=N
  8926.       MP=M
  8927.       IPSYM=0
  8928.       IF (NS.LT.1) RETURN
  8929.       XD=XW2-XW1
  8930.       YD=YW2-YW1
  8931.       ZD=ZW2-ZW1
  8932.       IF (ABS(RDEL-1.).LT.1.D-6) GO TO 1
  8933.       DELZ=SQRT(XD*XD+YD*YD+ZD*ZD)
  8934.       XD=XD/DELZ
  8935.       YD=YD/DELZ
  8936.       ZD=ZD/DELZ
  8937.       DELZ=DELZ*(1.-RDEL)/(1.-RDEL**NS)
  8938.       RD=RDEL
  8939.       GO TO 2
  8940. 1     FNS=NS
  8941.       XD=XD/FNS
  8942.       YD=YD/FNS
  8943.       ZD=ZD/FNS
  8944.       DELZ=1.
  8945.       RD=1.
  8946. 2     RADZ=RAD
  8947.       XS1=XW1
  8948.       YS1=YW1
  8949.       ZS1=ZW1
  8950.       DO 3 I=IST,N
  8951.       ITAG(I)=ITG
  8952.       XS2=XS1+XD*DELZ
  8953.       YS2=YS1+YD*DELZ
  8954.       ZS2=ZS1+ZD*DELZ
  8955.       X(I)=XS1
  8956.       Y(I)=YS1
  8957.       Z(I)=ZS1
  8958.       X2(I)=XS2
  8959.       Y2(I)=YS2
  8960.       Z2(I)=ZS2
  8961.       BI(I)=RADZ
  8962.       DELZ=DELZ*RD
  8963.       RADZ=RADZ*RRAD
  8964.       XS1=XS2
  8965.       YS1=YS2
  8966. 3     ZS1=ZS2
  8967.       X2(N)=XW2
  8968.       Y2(N)=YW2
  8969.       Z2(N)=ZW2
  8970.       RETURN
  8971.       END
  8972.       COMPLEX*16 FUNCTION ZINT(SIGL,ROLAM)
  8973. C ***
  8974. C     DOUBLE PRECISION 6/4/85
  8975. C
  8976.       IMPLICIT REAL*8(A-H,O-Z)
  8977. C ***
  8978. C
  8979. C     ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE
  8980. C
  8981. C
  8982.       COMPLEX*16 TH,PH,F,G,FJ,CN,BR1,BR2
  8983.       COMPLEX*16 CC1,CC2,CC3,CC4,CC5,CC6,CC7,CC8,CC9,CC10,CC11,CC12
  8984.      1,CC13,CC14
  8985.       DIMENSION FJX(2), CNX(2), CCN(28)
  8986.       EQUIVALENCE (FJ,FJX), (CN,CNX), (CC1,CCN(1)), (CC2,CCN(3)), (CC3,C
  8987.      1CN(5)), (CC4,CCN(7)), (CC5,CCN(9)), (CC6,CCN(11)), (CC7,CCN(13)),
  8988.      2(CC8,CCN(15)), (CC9,CCN(17)), (CC10,CCN(19)), (CC11,CCN(21)), (CC1
  8989.      32,CCN(23)), (CC13,CCN(25)), (CC14,CCN(27))
  8990.       DATA PI,POT,TP,TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0,
  8991.      12.368705D+3/
  8992.       DATA CMOTP/60.00/,FJX/0.,1./,CNX/.70710678D+0,.70710678D+0/
  8993.       DATA CCN/6.D-7,1.9D-6,-3.4D-6,5.1D-6,-2.52D-5,0.,-9.06D-5,-9.01D-5
  8994.      1,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,1.6D-6,
  8995.      2-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-1.3813D-3
  8996.      3,1.3811D-3,-6.25001D-2,-1.D-7,.7071068D+0,.7071068D+0/
  8997.       TH(D)=(((((CC1*D+CC2)*D+CC3)*D+CC4)*D+CC5)*D+CC6)*D+CC7
  8998.       PH(D)=(((((CC8*D+CC9)*D+CC10)*D+CC11)*D+CC12)*D+CC13)*D+CC14
  8999.       F(D)=SQRT(POT/D)*EXP(-CN*D+TH(-8./X))
  9000.       G(D)=EXP(CN*D+TH(8./X))/SQRT(TP*D)
  9001.       X=SQRT(TPCMU*SIGL)*ROLAM
  9002.       IF (X.GT.110.) GO TO 2
  9003.       IF (X.GT.8.) GO TO 1
  9004.       Y=X/8.
  9005.       Y=Y*Y
  9006.       S=Y*Y
  9007.       BER=((((((-9.01D-6*S+1.22552D-3)*S-.08349609D+0)*S+2.6419140D+0)
  9008.      1*S-32.363456D+0)*S+113.77778D+0)*S-64.)*S+1.
  9009.       BEI=((((((1.1346D-4*S-.01103667D+0)*S+.52185615D+0)*S-
  9010.      110.567658D+0)*S+72.817777D+0)*S-113.77778D+0)*S+16.)*Y
  9011.       BR1=DCMPLX(BER,BEI)
  9012.       BER=(((((((-3.94D-6*S+4.5957D-4)*S-.02609253D+0)*S+.66047849D+0)
  9013.      1*S-6.0681481D+0)*S+14.222222D+0)*S-4.)*Y)*X
  9014.       BEI=((((((4.609D-5*S-3.79386D-3)*S+.14677204D+0)*S-2.3116751D+0)
  9015.      1*S+11.377778D+0)*S-10.666667D+0)*S+.5)*X
  9016.       BR2=DCMPLX(BER,BEI)
  9017.       BR1=BR1/BR2
  9018.       GO TO 3
  9019. 1     BR2=FJ*F(X)/PI
  9020.       BR1=G(X)+BR2
  9021.       BR2=G(X)*PH(8./X)-BR2*PH(-8./X)
  9022.       BR1=BR1/BR2
  9023.       GO TO 3
  9024. 2     BR1=DCMPLX(.70710678D+0,-.70710678D+0)
  9025. 3     ZINT=FJ*SQRT(CMOTP/SIGL)*BR1/ROLAM
  9026.       RETURN
  9027.       END
  9028.       logical*4 function GetPut(what,where,message,file,volume,nt,types)
  9029. C
  9030. C      implicit none
  9031. C
  9032. C      integer NEWHANDLE
  9033. C      parameter (NEWHANDLE = Z'122000A8')
  9034. C      integer HLOCK
  9035. C      parameter (HLOCK = Z'02980008')
  9036. C      integer HUNLOCK
  9037. C      parameter (HUNLOCK = Z'02A80008')
  9038. C      integer NEWDIALOG
  9039. C      parameter (NEWDIALOG = Z'97D20002')
  9040. C      integer DISPOSHANDLE
  9041. C      parameter (DISPOSHANDLE = Z'02380008')
  9042. C      integer SFPUTFILE
  9043. C      parameter (SFPUTFILE = Z'9EA16CB1')
  9044. C      integer SFGETFILE
  9045. C      parameter (SFGETFILE = Z'9EA20003')
  9046. C      integer PTR
  9047. C      parameter (PTR = Z'C0000000')
  9048. C      integer DISPOSEDIALOG
  9049. C      parameter (DISPOSEDIALOG = Z'98310000')
  9050. C      integer PBSETVOL
  9051. C      parameter (PBSETVOL = Z'01580010')
  9052. C
  9053. C      integer*4 what                ! 0 SFPUTFILE; 1 SFGETFILE
  9054. C      integer*2 where(2)            ! location of box upper-left corner (y,x)
  9055. C      character*(*) message         ! string to go over dialog box
  9056. C      character*(*) file            ! file name
  9057. C      integer*4 volume              ! volume number
  9058. C      integer*4 nt                  ! number of filter types
  9059. C      character*(*) types           ! filter types
  9060. C
  9061. C      integer*4 toolbx              ! toolbx interface
  9062. C
  9063. C      integer*4 dptr                ! dialog pointer
  9064. C      character*64 fname
  9065. C      logical*1 good                ! result flag
  9066. C      integer*4 i
  9067. C      integer*2 iovrefnum
  9068. C      integer*4 lhdl                      ! handle of item list
  9069. C      integer*4 lptr                      ! pointer to item list
  9070. C      integer*4 nc                        ! number of characters in file name
  9071. C      integer*2 posd(2)                   ! location of standard dialog
  9072. C      integer*2 rect(4)                   ! rectangle
  9073. C      integer*2 vrefnum
  9074. C      integer*1 params(108)                ! partial PBGETVOL parameter block
  9075. C      equivalence (params(23),iovrefnum)
  9076. C      integer*1 reply(76)                 ! reply record
  9077. C      equivalence (reply(1),good)
  9078. C      equivalence (reply(7),vrefnum)
  9079. C      equivalence (reply(11),fname)
  9080. C
  9081. C      GetPut = .false.
  9082. C      volume = 0
  9083. C      good = .true.
  9084. C      if (what .eq. 0) then
  9085. C        lhdl = 0
  9086. C        lhdl = toolbx(NEWHANDLE,72)
  9087. C        if (lhdl .eq. 0) return
  9088. C        call toolbx(HLOCK,lhdl)
  9089. C        lptr = LONG(lhdl)
  9090. C        WORD(lptr) = 1
  9091. C        LONG(lptr + 2) = 0
  9092. C        WORD(lptr + 6) = 0
  9093. C        WORD(lptr + 8) = 0
  9094. C        WORD(lptr + 10) = 32
  9095. C        WORD(lptr + 12) = 32
  9096. C        BYTE(lptr + 14) = 160
  9097. C        BYTE(lptr + 15) = 2
  9098. C        WORD(lptr + 16) = 1
  9099. C        LONG(lptr + 18) = 0
  9100. C        WORD(lptr + 22) = 8
  9101. C        WORD(lptr + 24) = 40
  9102. C        WORD(lptr + 26) = 24
  9103. C        WORD(lptr + 28) = 304
  9104. C        BYTE(lptr + 30) = 136
  9105. C        BYTE(lptr + 31) = 40
  9106. C        do (i = 1, 40)
  9107. C          BYTE(lptr + 31 + i) = ICHAR(message(i:i))
  9108. C        enddo
  9109. C        call toolbx(HUNLOCK,lhdl)
  9110. C        rect(1) = where(1)
  9111. C        rect(2) = where(2)
  9112. C        rect(3) = rect(1) + 32
  9113. C        rect(4) = rect(2) + 304
  9114. C      elseif (what .eq. 1) then
  9115. C        lhdl = 0
  9116. C        lhdl = toolbx(NEWHANDLE,80)
  9117. C        if (lhdl .eq. 0) return
  9118. C        call toolbx(HLOCK,lhdl)
  9119. C        lptr = LONG(lhdl)
  9120. C        WORD(lptr) = 1
  9121. C        LONG(lptr + 2) = 0
  9122. C        WORD(lptr + 6) = 0
  9123. C        WORD(lptr + 8) = 0
  9124. C        WORD(lptr + 10) = 32
  9125. C        WORD(lptr + 12) = 32
  9126. C        BYTE(lptr + 14) = 160
  9127. C        BYTE(lptr + 15) = 2
  9128. C        WORD(lptr + 16) = 1
  9129. C        LONG(lptr + 18) = 0
  9130. C        WORD(lptr + 22) = 8
  9131. C        WORD(lptr + 24) = 40
  9132. C        WORD(lptr + 26) = 24
  9133. C        WORD(lptr + 28) = 348
  9134. C        BYTE(lptr + 30) = 136
  9135. C        BYTE(lptr + 31) = 48
  9136. C        do (i = 1, 48)
  9137. C          BYTE(lptr + 31 + i) = ICHAR(message(i:i))
  9138. C        enddo
  9139. C        call toolbx(HUNLOCK,lhdl)
  9140. C        rect(1) = where(1)
  9141. C        rect(2) = where(2)
  9142. C        rect(3) = rect(1) + 32
  9143. C        rect(4) = rect(2) + 348
  9144. C      else
  9145. C        return
  9146. C      endif
  9147. C      dptr = 0
  9148. C      dptr = toolbx(NEWDIALOG,0,rect,0,.true.,1,-1,.false.,0,lhdl)
  9149. C      if (dptr .eq. 0) then
  9150. C        call toolbx(DISPOSHANDLE,lhdl)
  9151. C        return
  9152. C      endif
  9153. C      posd(1) = where(1) + 50
  9154. C      posd(2) = where(2)
  9155. C      if (what .eq. 0) then
  9156. C        call toolbx(SFPUTFILE,posd,0,0,0,reply,1)
  9157. C      else
  9158. C        call toolbx(SFGETFILE,posd,0,0,nt,toolbx(PTR,types),0,reply,2)
  9159. C      endif
  9160. C      call toolbx(DISPOSEDIALOG,dptr)                 ! Dispose of Header dialog
  9161. C      if (good .eq. .false.) return
  9162. C      nc = ICHAR(fname(1:1))
  9163. C      file = fname(2:nc + 1)
  9164. C      do (i = 1, 108)
  9165. C        params(i) = 0
  9166. C      enddo
  9167. C      iovrefnum = vrefnum
  9168. C      if (toolbx(PBSETVOL,toolbx(PTR,params)) .eq. 0) then
  9169. C        GetPut = .true.
  9170. C        volume = vrefnum
  9171. C      endif
  9172. C
  9173.       return
  9174.       end
  9175.